Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
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()
    Application.OnKey "^{LEFT}", "SetPodbor"
    Application.OnKey "^{RIGHT}", "SetFind"
    Application.OnKey "^{UP}", "SetFindPrev"
    Application.OnKey "^{DOWN}", "SetFindNext"
    MyVer_Check False
    GetNeedUpdate
End Sub


Attribute VB_Name = "Price"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
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 Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    SetPodbor Target.Row
End Sub





Attribute VB_Name = "Hide"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
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_Name = "Dictionary"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Attribute VB_Description = "Drop-in replacement for Scripting.Dictionary on Mac\r\n\r\nDictionary v1.4.0\r\n(c) Tim Hall - https://github.com/timhall/VBA-Dictionary\r\nAuthor: tim.hall.engr@gmail.com\r\nLicense: MIT (http://www.opensource.org/licenses/mit-license.php)\r\n"
''
' Dictionary v1.4.1
' (c) Tim Hall - https://github.com/timhall/VBA-Dictionary
'
' Drop-in replacement for Scripting.Dictionary on Mac
'
' @author: tim.hall.engr@gmail.com
' @license: MIT (http://www.opensource.org/licenses/mit-license.php
'
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
Option Explicit

' --------------------------------------------- '
' Constants and Private Variables
' --------------------------------------------- '

#Const UseScriptingDictionaryIfAvailable = False

#If Mac Or Not UseScriptingDictionaryIfAvailable Then

' KeyValue 0: FormattedKey, 1: OriginalKey, 2: Value
Private pKeyValues As Collection
Private pKeys() As Variant
Private pItems() As Variant
Private pObjectKeys As Collection
Private pCompareMode As CompareMethod

#Else

Private pDictionary As Object

#End If

' --------------------------------------------- '
' Types
' --------------------------------------------- '

Public Enum CompareMethod
    BinaryCompare = VBA.vbBinaryCompare
    TextCompare = VBA.vbTextCompare
    DatabaseCompare = VBA.vbDatabaseCompare
End Enum

' --------------------------------------------- '
' Properties
' --------------------------------------------- '

Public Property Get CompareMode() As CompareMethod
Attribute CompareMode.VB_Description = "Set or get the string comparison method."
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    CompareMode = pCompareMode
#Else
    CompareMode = pDictionary.CompareMode
#End If
End Property
Public Property Let CompareMode(value As CompareMethod)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Count > 0 Then
        ' Can't change CompareMode for Dictionary that contains data
        ' http://msdn.microsoft.com/en-us/library/office/gg278481(v=office.15).aspx
        Err.Raise 5 ' Invalid procedure call or argument
    End If

    pCompareMode = value
#Else
    pDictionary.CompareMode = value
#End If
End Property

Public Property Get Count() As Long
Attribute Count.VB_Description = "Get the number of items in the dictionary.\n"
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Count = pKeyValues.Count
#Else
    Count = pDictionary.Count
#End If
End Property

Public Property Get Item(key As Variant) As Variant
Attribute Item.VB_Description = "Set or get the item for a given key."
Attribute Item.VB_UserMemId = 0
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Dim KeyValue As Variant
    KeyValue = GetKeyValue(key)

    If Not IsEmpty(KeyValue) Then
        If VBA.IsObject(KeyValue(2)) Then
            Set Item = KeyValue(2)
        Else
            Item = KeyValue(2)
        End If
    Else
        ' Not found -> Returns Empty
    End If
#Else
    If VBA.IsObject(pDictionary.Item(key)) Then
        Set Item = pDictionary.Item(key)
    Else
        Item = pDictionary.Item(key)
    End If
#End If
End Property
Public Property Let Item(key As Variant, value As Variant)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Exists(key) Then
        ReplaceKeyValue GetKeyValue(key), key, value
    Else
        AddKeyValue key, value
    End If
#Else
    pDictionary.Item(key) = value
#End If
End Property
Public Property Set Item(key As Variant, value As Variant)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Exists(key) Then
        ReplaceKeyValue GetKeyValue(key), key, value
    Else
        AddKeyValue key, value
    End If
#Else
    Set pDictionary.Item(key) = value
#End If
End Property

Public Property Let key(Previous As Variant, Updated As Variant)
Attribute key.VB_Description = "Change a key to a different key."
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Dim KeyValue As Variant
    KeyValue = GetKeyValue(Previous)

    If Not VBA.IsEmpty(KeyValue) Then
        ReplaceKeyValue KeyValue, Updated, KeyValue(2)
    End If
#Else
    pDictionary.key(Previous) = Updated
#End If
End Property

' ============================================= '
' Public Methods
' ============================================= '

''
' Add an item with the given key
'
' @param {Variant} Key
' @param {Variant} Item
' --------------------------------------------- '
Public Sub Add(key As Variant, Item As Variant)
Attribute Add.VB_Description = "Add a new key and item to the dictionary."
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Not Me.Exists(key) Then
        AddKeyValue key, Item
    Else
        ' This key is already associated with an element of this collection
        Err.Raise 457
    End If
#Else
    pDictionary.Add key, Item
#End If
End Sub

''
' Check if an item exists for the given key
'
' @param {Variant} Key
' @return {Boolean}
' --------------------------------------------- '
Public Function Exists(key As Variant) As Boolean
Attribute Exists.VB_Description = "Determine if a given key is in the dictionary."
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Exists = Not IsEmpty(GetKeyValue(key))
#Else
    Exists = pDictionary.Exists(key)
#End If
End Function

''
' Get an array of all items
'
' @return {Variant}
' --------------------------------------------- '
Public Function Items() As Variant
Attribute Items.VB_Description = "Get an array containing all items in the dictionary."
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Count > 0 Then
        Items = pItems
    Else
        ' Split("") creates initialized empty array that matches Dictionary Keys and Items
        Items = VBA.Split("")
    End If
#Else
    Items = pDictionary.Items
#End If
End Function

''
' Get an array of all keys
'
' @return {Variant}
' --------------------------------------------- '
Public Function Keys() As Variant
Attribute Keys.VB_Description = "Get an array containing all keys in the dictionary."
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Count > 0 Then
        Keys = pKeys
    Else
        ' Split("") creates initialized empty array that matches Dictionary Keys and Items
        Keys = VBA.Split("")
    End If
#Else
    Keys = pDictionary.Keys
#End If
End Function

''
' Remove an item for the given key
'
' @param {Variant} Key
' --------------------------------------------- '
Public Sub Remove(key As Variant)
Attribute Remove.VB_Description = "Remove a given key from the dictionary."
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Dim KeyValue As Variant
    KeyValue = GetKeyValue(key)

    If Not VBA.IsEmpty(KeyValue) Then
        RemoveKeyValue KeyValue
    Else
        ' Application-defined or object-defined error
        Err.Raise 32811
    End If
#Else
    pDictionary.Remove key
#End If
End Sub

''
' Remove all items
' --------------------------------------------- '
Public Sub RemoveAll()
Attribute RemoveAll.VB_Description = "Remove all information from the dictionary."
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Set pKeyValues = New Collection

    Erase pKeys
    Erase pItems
#Else
    pDictionary.RemoveAll
#End If
End Sub

' ============================================= '
' Private Functions
' ============================================= '

#If Mac Or Not UseScriptingDictionaryIfAvailable Then

Private Function GetKeyValue(key As Variant) As Variant
    On Error Resume Next
    GetKeyValue = pKeyValues(GetFormattedKey(key))
    Err.Clear
End Function

Private Sub AddKeyValue(key As Variant, value As Variant, Optional Index As Long = -1)
    If Me.Count = 0 Then
        ReDim pKeys(0 To 0)
        ReDim pItems(0 To 0)
    Else
        ReDim Preserve pKeys(0 To UBound(pKeys) + 1)
        ReDim Preserve pItems(0 To UBound(pItems) + 1)
    End If

    Dim FormattedKey As String
    FormattedKey = GetFormattedKey(key)

    If Index >= 0 And Index < pKeyValues.Count Then
        ' Shift keys/items after + including index into empty last slot
        Dim i As Long
        For i = UBound(pKeys) To Index + 1 Step -1
            pKeys(i) = pKeys(i - 1)
            If VBA.IsObject(pItems(i - 1)) Then
                Set pItems(i) = pItems(i - 1)
            Else
                pItems(i) = pItems(i - 1)
            End If
        Next i

        ' Add key/item at index
        pKeys(Index) = key
        If VBA.IsObject(value) Then
            Set pItems(Index) = value
        Else
            pItems(Index) = value
        End If

        ' Add key-value at proper index
        pKeyValues.Add Array(FormattedKey, key, value), FormattedKey, Before:=Index + 1
    Else
        ' Add key-value as last item
        If VBA.IsObject(key) Then
            Set pKeys(UBound(pKeys)) = key
        Else
            pKeys(UBound(pKeys)) = key
        End If
        If VBA.IsObject(value) Then
            Set pItems(UBound(pItems)) = value
        Else
            pItems(UBound(pItems)) = value
        End If

        pKeyValues.Add Array(FormattedKey, key, value), FormattedKey
    End If
End Sub

Private Sub ReplaceKeyValue(KeyValue As Variant, key As Variant, value As Variant)
    Dim Index As Long
    Dim i As Integer

    Index = GetKeyIndex(KeyValue(1))

    ' Remove existing Value
    RemoveKeyValue KeyValue, Index

    ' Add new Key Value back
    AddKeyValue key, value, Index
End Sub

Private Sub RemoveKeyValue(KeyValue As Variant, Optional ByVal Index As Long = -1)
    Dim i As Long
    If Index = -1 Then
        Index = GetKeyIndex(KeyValue(1))
    End If

    If Index >= 0 And Index <= UBound(pKeys) Then
        ' Shift keys/items after index down
        For i = Index To UBound(pKeys) - 1
            pKeys(i) = pKeys(i + 1)

            If VBA.IsObject(pItems(i + 1)) Then
                Set pItems(i) = pItems(i + 1)
            Else
                pItems(i) = pItems(i + 1)
            End If
        Next i

        ' Resize keys/items to remove empty slot
        If UBound(pKeys) = 0 Then
            Erase pKeys
            Erase pItems
        Else
            ReDim Preserve pKeys(0 To UBound(pKeys) - 1)
            ReDim Preserve pItems(0 To UBound(pItems) - 1)
        End If
    End If

    pKeyValues.Remove KeyValue(0)
    RemoveObjectKey KeyValue(1)
End Sub

Private Function GetFormattedKey(key As Variant) As String
    If VBA.IsObject(key) Then
        GetFormattedKey = GetObjectKey(key)
    ElseIf VarType(key) = VBA.vbBoolean Then
        GetFormattedKey = IIf(key, "-1__-1", "0__0")
    ElseIf VarType(key) = VBA.vbString Then
        GetFormattedKey = key

        If Me.CompareMode = CompareMethod.BinaryCompare Then
            ' Collection does not have method of setting key comparison
            ' So case-sensitive keys aren't supported by default
            ' -> Approach: Append lowercase characters to original key
            '    AbC -> AbC___b_, abc -> abc__abc, ABC -> ABC_____
            Dim Lowercase As String
            Lowercase = ""

            Dim i As Integer
            Dim Char As String
            Dim Ascii As Integer
            For i = 1 To VBA.Len(GetFormattedKey)
                Char = VBA.Mid$(GetFormattedKey, i, 1)
                Ascii = VBA.Asc(Char)
                If Ascii >= 97 And Ascii <= 122 Then
                    Lowercase = Lowercase & Char
                Else
                    Lowercase = Lowercase & "_"
                End If
            Next i

            If Lowercase <> "" Then
                GetFormattedKey = GetFormattedKey & "__" & Lowercase
            End If
        End If
    Else
        ' For numbers, add duplicate to distinguish from strings
        ' ->  123  -> "123__123"
        '    "123" -> "123"
        GetFormattedKey = VBA.CStr(key) & "__" & CStr(key)
    End If
End Function

Private Function GetObjectKey(ObjKey As Variant) As String
    Dim i As Integer
    For i = 1 To pObjectKeys.Count
        If pObjectKeys.Item(i) Is ObjKey Then
            GetObjectKey = "__object__" & i
            Exit Function
        End If
    Next i

    pObjectKeys.Add ObjKey
    GetObjectKey = "__object__" & pObjectKeys.Count
End Function

Private Sub RemoveObjectKey(ObjKey As Variant)
    Dim i As Integer
    For i = 1 To pObjectKeys.Count
        If pObjectKeys.Item(i) Is ObjKey Then
            pObjectKeys.Remove i
            Exit Sub
        End If
    Next i
End Sub

Private Function GetKeyIndex(key As Variant) As Long
    Dim i As Long
    For i = 0 To UBound(pKeys)
        If VBA.IsObject(pKeys(i)) And VBA.IsObject(key) Then
            If pKeys(i) Is key Then
                GetKeyIndex = i
                Exit For
            End If
        ElseIf VBA.IsObject(pKeys(i)) Or VBA.IsObject(key) Then
            ' Both need to be objects to check equality, skip
        ElseIf pKeys(i) = key Then
            GetKeyIndex = i
            Exit For
        End If
    Next i
End Function

#End If

Private Sub Class_Initialize()
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Set pKeyValues = New Collection

    Erase pKeys
    Erase pItems
    Set pObjectKeys = New Collection
#Else
    Set pDictionary = CreateObject("Scripting.Dictionary")
#End If
End Sub

Private Sub Class_Terminate()
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Set pKeyValues = Nothing
    Set pObjectKeys = Nothing
#Else
    Set pDictionary = Nothing
#End If
End Sub

Attribute VB_Name = "frmPodbor"
Attribute VB_Base = "0{41EBBF71-48EE-438D-A52E-BB6BCAF5B314}{EDAF2A77-9A7D-4733-AD3A-CD8CB4A9F0A1}"
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

'Функции API, применяемые для поиска окна и изменения его стиля
#If VBA7 Then
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hWnd As Long) As Long
#End If

'константы для функций API
Private Const GWL_STYLE As Long = -16& 'для установки нового вида окна
Private Const GWL_EXSTYLE = -20& 'для расширенного стиля окна
Private Const WS_CAPTION As Long = &HC00000 'определяет заголовок
Private Const WS_BORDER As Long = &H800000 'определяет рамку формы

Public ActiveRow As Long
Private GoodAmoFlag As Boolean
Private MonoBrand As String
Private MonoSite As String
Private MonoUrl As String
Private OnOnline As Boolean
Private pcsName As String
Private retPack As Integer

Private MyX As Single, MyY As Single

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MyX = X
    MyY = Y
End Sub

Private Sub lblCaption_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MyX = X
    MyY = Y
End Sub

Private Sub imgPhoto__MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MyX = X
    MyY = Y
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim LastX As Single, LastY As Single
    If Button = 1 And MyX > 0 Then
        Me.Move Me.Left + X - MyX, Me.Top + Y - MyY
    End If
End Sub

Private Sub lblCaption_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim LastX As Single, LastY As Single
    If Button = 1 And MyX > 0 Then
        Me.Move Me.Left + X - MyX, Me.Top + Y - MyY
    End If
End Sub

Private Sub imgPhoto__MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim LastX As Single, LastY As Single
    If Button = 1 And MyX > 0 Then
        Me.Move Me.Left + X - MyX, Me.Top + Y - MyY
    End If
End Sub

Private Sub UserForm_Initialize()
    Dim ihWnd, hStyle
    'ищем окно формы среди всех открытых окон
    If Val(Application.Version) < 9 Then
        ihWnd = FindWindow("ThunderXFrame", Me.Caption) 'для Excel 97
    Else
        ihWnd = FindWindow("ThunderDFrame", Me.Caption) 'для Excel 2000 и выше
    End If
    'получаем информацию о найденном окне(стили и т.д.)
    hStyle = GetWindowLong(ihWnd, GWL_STYLE)
    'назначаем переменной новый стиль для окна формы
    hStyle = hStyle And Not WS_CAPTION And Not WS_BORDER
    'изменяем вид окна: убираем меню(заголовок) и рамку
    SetWindowLong ihWnd, GWL_STYLE, hStyle
    SetWindowLong ihWnd, GWL_EXSTYLE, 0
    'перерисовываем форму, точнее строку меню(заголовка)
    DrawMenuBar ihWnd
    'меняем размер формы, т.к. сделали смещение элементов формы вверх на высоту заголовка
    Me.Height = Me.Height + GWL_EXSTYLE
End Sub

Sub ShowForm(MyRow As Long)
    ActiveRow = MyRow
    Me.lblCaption = Range(wsPrice & colProdName & ActiveRow) & " - " & Range(wsPrice & colType & ActiveRow)
    LoadImg
    LoadPack
    LoadOrder
    Me.txtAmount = Val(Range(wsPrice & colOrder & MyRow))
    Me.lstVariants.visible = False
    Dim S, SS() As String
    SS = Split(ProdactSiteBrands, ",")
    MonoBrand = ""
    For Each S In SS
        If InStr(1, Range(wsPrice & colProdName & ActiveRow).value, S, vbTextCompare) > 0 Then
            MonoBrand = S
            If GetParam("OnLine") Then
                OnOnline = True
                If S = "garin" Then MonoBrand = MonoBrand & "-tm"
                MonoSite = Replace(ProdactSiteName, "#BRAND#", MonoBrand)
                MonoUrl = Replace(Replace(ProdactSiteUrl, "#BRAND#", MonoBrand), "#TID#", Range(wsPrice & colCode & ActiveRow))
            End If
            Exit For
        End If
    Next
    ShowVariants False
    With txtAmount
        .SelStart = 0
        .SelLength = Len(txtAmount.Text)
    End With
    Me.Show
End Sub

Sub LoadPack()
    Dim packLine As String, Pack, Packs, Stock As Long, tType As String, tName As String, S As String
    Stock = Range(wsPrice & colStock & ActiveRow)
    retPack = Range(wsPrice & colRetPack & ActiveRow)
    retPackMode = Len(Range(rCustomerPPA)) > 5
    tType = Range(wsPrice & colProdType & ActiveRow)
    tName = Range(wsPrice & colProdName & ActiveRow)
    If retPackMode And retPack > 1 Then
        'Для ритэйл упаковки
        If InStr(tName, "BL") > 0 Then
            S = "Блистер"
            pcsName = "BL"
        ElseIf InStr(tName, "SR") > 0 Then
            S = "Шринк"
            pcsName = "SR"
        Else
            S = "Упаковка"
            pcsName = "BOX"
        End If
        S = S & " (" & pcsName & ") содержит "
        S = S & retPack & " "
        If InStr(tType, "Элемент") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Элемента"
            Else
                S = S & "Элементов"
            End If
        ElseIf InStr(tType, "Аккумулятор") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Аккумулятора"
            Else
                S = S & "Аккумуляторов"
            End If
        ElseIf InStr(tType, "Батарея") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Батареи"
            Else
                S = S & "Батарей"
            End If
        ElseIf InStr(tType, "Лампа") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Лампы"
            Else
                S = S & "Ламп"
            End If
        ElseIf InStr(tType, "Разъём") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Разъёма"
            Else
                S = S & "Разъёмов"
            End If
        ElseIf InStr(tType, "диск") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Диска"
            Else
                S = S & "Дисков"
            End If
        ElseIf InStr(tType, "Штекер") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Штекера"
            Else
                S = S & "Штекеров"
            End If
        ElseIf InStr(tType, "Заглушка") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Заглушки"
            Else
                S = S & "Заглушек"
            End If
        ElseIf InStr(tType, "клемм") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Клеммы"
            Else
                S = S & "Клемм"
            End If
        ElseIf InStr(tType, "Коннектор") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Коннектора"
            Else
                S = S & "Коннекторов"
            End If
        ElseIf InStr(tType, "Перчатки") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Перчатки"
            Else
                S = S & "Перчаток"
            End If
        ElseIf InStr(tType, "Гриппер") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Гриппера"
            Else
                S = S & "Грипперов"
            End If
        ElseIf InStr(tType, "Освежитель") > 0 Then
            If retPack > 1 And retPack < 5 Then
                S = S & "Освежителя"
            Else
                S = S & "Освежителей"
            End If
        Else
            If retPack > 1 And retPack < 5 Then
                S = S & "Штуки"
            Else
                S = S & "Штук"
            End If
        End If
        lblStock_.Caption = "!" & S & vbNewLine
        pcsName = " " & pcsName
    Else
        pcsName = " Шт."
        lblStock_.Caption = ""
    End If
    lblStock_.Caption = lblStock_.Caption & Replace("Для заказа доступно " & Format(Stock, "# ##0") & pcsName, "  ", " ")
    'Список упаковок
    packLine = Range(wsPrice & colPackLine & ActiveRow)
    Packs = Split(packLine, "/")
    lstPackList.AddItem Trim(pcsName)
    lstPackList.Column(1, 0) = 1
    For Each Pack In Packs
        If Pack > 1 Then lstPackList.AddItem "Упак. по " & Pack & pcsName
        lstPackList.Column(1, lstPackList.ListCount - 1) = Pack
        If Pack > 1 Then If Stock \ Pack > 0 Then lblStock_.Caption = lblStock_.Caption & vbNewLine & Replace("или " & Format(Stock \ Pack, "# ##0") & " упак. по " & Pack & pcsName, "  ", " ")
    Next
    lstPackList.ListIndex = 0
    If Stock > 0 Then
        lblCaption.BackColor = &HCC9900
        lblCaptionPlus.BackColor = &HCC9900
    Else
        lblCaption.Caption = "ТОВАРА ВРЕМЕННО НЕТ НА СКЛАДЕ!!!  " & lblCaption.Caption
        lblCaption.BackColor = &HFF&
        lblCaptionPlus.BackColor = &HFF&
    End If
End Sub

Sub LoadOrder()
    Dim LastOrderQty As Long, LastOrderDate As Date
    LastOrderQty = Range(wsPrice & colLastOrderQty & ActiveRow)
    If LastOrderQty > 0 Then
        LastOrderDate = CDate(Range(wsPrice & colLastOrderDate & ActiveRow))
        If retPackMode And retPack > 1 Then
            lblLastOrder_.Caption = "Дата: " & LastOrderDate & " (" & Int(Now()) - LastOrderDate & " дней назад)" & _
            vbNewLine & "Количество: " & LastOrderQty / retPack & pcsName & _
            vbNewLine & "Цена: " & Range(wsPrice & colLastOrderPrice & ActiveRow) * retPack & " руб."
        Else
            lblLastOrder_.Caption = "Дата: " & LastOrderDate & " (" & Int(Now()) - LastOrderDate & " дней назад)" & _
            vbNewLine & "Количество: " & LastOrderQty & pcsName & _
            vbNewLine & "Цена: " & Range(wsPrice & colLastOrderPrice & ActiveRow) & " руб."
        End If
    ElseIf Range(wsPrice & colStatus & ActiveRow).value = 2 Then
        lblLastOrder_.Caption = "ТОВАР НОВИНКА!" & vbNewLine & "Эта позиция появилась в нашем ассортименте после " & Range(rLastOrderDate)
    Else
        lblLastOrder_.Caption = "Вы заказываете этот товар впервые."
    End If
    btnCopyQtyFromLastOrder.Enabled = (LastOrderQty > 0)
End Sub

Sub LoadImg()
    Const DummyImgLen As Long = 9595  'Примечание: Изображение Пустышка имеет длину 9595 и игнорируется при загрузке
    Dim LocalFile As String
    Dim ImgFileName As String
    On Error GoTo Err
    Me.lblImgError_.visible = False
    ImgFileName = Range(wsPrice & colCode & ActiveRow) & ".jpg"
    'Полный путь
    LocalFile = GetParam("ImgPath") & "\" & ImgFileName
    'Если пустышка, то убиваем
    If Len(Dir(LocalFile)) > 2 Then If FileLen(LocalFile) = DummyImgLen Or FileLen(LocalFile) = 0 Then Kill LocalFile
    'Если локального ещё нет, то скачиваем
    If Len(Dir(LocalFile)) < 3 Then
        If Len(MonoBrand) > 0 Then
            If OnOnline Then
                Application.StatusBar = "Загрузка изображения товара ... (Вы можете загрузить сразу все изображения в диалоге Установок)"
                DownloadFileNew "JPG", Range(rImgBaseUrl) & Range(wsPrice & colCode & ActiveRow) & ".jpg", LocalFile
                Application.StatusBar = False
            End If
        Else
            If GetParam("OnLine") Then
                Application.StatusBar = "Загрузка изображения товара ... (Вы можете загрузить сразу все изображения в диалоге Установок)"
                DownloadFileNew "JPG", Range(rImgBaseUrl) & Range(wsPrice & colCode & ActiveRow) & ".jpg", LocalFile
                Application.StatusBar = False
            End If
        End If
    End If
    imgPhoto_.Picture = loadPicture(LocalFile)
    SetResize
    Exit Sub
Err:
    Me.lblImgError_.visible = True
    SetResize
End Sub

'=============================================================

Sub ShowVariants(SetShow As Boolean)
    lstVariants.visible = SetShow
    lblVariants.visible = SetShow
    If Len(MonoBrand) > 0 And OnOnline Then
        btnProdactInfo.visible = Not SetShow
        btnProdactInfo.Caption = "Нужно больше информации? Откройте этот товар на сайте " & MonoSite
    Else
        btnProdactInfo.visible = False
    End If
End Sub

Sub ReCalc()
    Dim Amo As Long, AmoCalc As Long
    Amo = Val(Me.txtAmount)
    AmoCalc = Amo
    If Me.lstPackList.ListIndex > 0 Then
        'Если по упаковкам, то количество не парит
        GoodAmoFlag = True
        AmoCalc = Me.lstPackList.Column(1, Me.lstPackList.ListIndex) * Amo
        ShowVariants False
    Else
        'Надо показать варианты
        Dim packLine As String, Pack, Packs
        Dim IamFirst As Boolean
        IamFirst = True
        packLine = Range(wsPrice & colPackLine & ActiveRow)
        Packs = Split(packLine, "/")
        GoodAmoFlag = (Amo / Packs(0) = Amo \ Packs(0))
        If Not GoodAmoFlag Then
            lstVariants.Clear
            ShowVariants True
            For Each Pack In Packs
                If Amo < Pack Then
                    'Если меньше минимальной упаковки
                    If ((Pack - Amo) < Amo / 2 Or IamFirst) And IsNotInVariants(Pack) Then
                        lstVariants.AddItem "+" & Pack - Amo & " --> " & Pack & pcsName
                        lstVariants.Column(1, lstVariants.ListCount - 1) = Pack
                    End If
                Else
                    'Если кратность, даём больше и меньше
                    If (Amo \ Pack + 1) * Pack - Amo < Amo / 2 And IsNotInVariants((Amo \ Pack + 1) * Pack) Then
                        lstVariants.AddItem "+" & (Amo \ Pack + 1) * Pack - Amo & " --> " & (Amo \ Pack + 1) * Pack & pcsName
                        lstVariants.Column(1, lstVariants.ListCount - 1) = (Amo \ Pack + 1) * Pack
                    End If
                    If Amo - (Amo \ Pack) * Pack < Amo / 2 And IsNotInVariants((Amo \ Pack) * Pack) Then
                        lstVariants.AddItem (Amo \ Pack) * Pack - Amo & " --> " & (Amo \ Pack) * Pack & pcsName
                        lstVariants.Column(1, lstVariants.ListCount - 1) = (Amo \ Pack) * Pack
                    End If
                End If
                IamFirst = False
            Next
        Else
            ShowVariants False
        End If
    End If

    'Если неправильное количество, то краснеем
    Me.lblBorderUp.BackColor = IIf(GoodAmoFlag, &HC000&, &H40C0&)
    Me.lblBorderDown.BackColor = Me.lblBorderUp.BackColor
    Me.lblInfo.ForeColor = Me.lblBorderUp.BackColor
    Me.lblInfo.Caption = IIf(GoodAmoFlag, AmoCalc & " x " & Range(wsPrice & colPrice & ActiveRow) & _
    " = " & Format(AmoCalc * Range(wsPrice & colPrice & ActiveRow), "# ##0.00") & " руб.", "Пожалуйста, уточните количество")
    
    Me.lblAmoCalc = AmoCalc
    
End Sub

Function IsNotInVariants(MyVal) As Boolean
    Dim i, n As Long
    IsNotInVariants = True
    For n = 0 To Me.lstVariants.ListCount - 1
        If Val(Me.lstVariants.Column(1, n)) = MyVal Then
            IsNotInVariants = False
            Exit Function
        End If
    Next
End Function

'=============================================================

Sub LoadAmoVars(Amo As Long)
    Dim packLine As String, Pack, Packs, Stock As Long
    Dim AmoP25 As Long, AmoM13 As Long, IamFirst As Boolean
    IamFirst = True
    Stock = Range(wsPrice & colStock & ActiveRow)
    packLine = Range(wsPrice & colPackLine & ActiveRow)
    Packs = Split(packLine, "/")
    
    If Amo / Packs(0) = Amo \ Packs(0) Then
        lstVariants.visible = False
        lblVariants.visible = False
        GoodAmoFlag = True
    Else
        lstVariants.Clear
        lstVariants.visible = True
        lblVariants.visible = True
        GoodAmoFlag = False
        AmoP25 = Amo * 1.25
        AmoM13 = Amo * 0.87
        For Each Pack In Packs
            If Amo < Pack And AmoP25 > Pack Then
                lstVariants.AddItem "+" & Pack - Amo & " --> " & Pack & pcsName
            ElseIf Amo < Pack And IamFirst Then
                lstVariants.AddItem "+" & Pack - Amo & " --> " & Pack & pcsName
            End If
            If Amo > Pack And AmoM13 < Pack Then lstVariants.AddItem Pack - Amo & " --> " & Pack & pcsName
            IamFirst = False
        Next
    End If
End Sub

Sub SaveAmount()
    Dim MyDialog As Integer
    Dim qString As String
    Dim MyStock As Long
    If GoodAmoFlag Then
        If Val(Me.lblAmoCalc) > 0 Then
            MyStock = Range(wsPrice & colStock & ActiveRow).value
            If MyStock < Val(Me.lblAmoCalc) Then
                If MyStock = 0 Then
                    qString = "Исключить этот товар из заказа?"
                Else
                    qString = "Сократить заказываемое количество до " & MyStock & " шт.?"
                End If
                MyDialog = MsgBox("Товар: " & Range(wsPrice & colProdName & ActiveRow).value & _
                vbNewLine & "Тип: " & Range(wsPrice & colType & ActiveRow).value & _
                vbNewLine & _
                vbNewLine & "Заказываемое количество: " & Val(Me.lblAmoCalc) & _
                vbNewLine & "Превышает имеющееся: " & MyStock & _
                vbNewLine & _
                vbNewLine & qString, vbYesNoCancel + vbQuestion, "Недостаточное количество на складе!")
                If MyDialog = vbCancel Then
                    Exit Sub
                ElseIf MyDialog = vbYes Then
                    Me.lblAmoCalc = MyStock
                    SaveAmount
                    Exit Sub
                End If
                Range(wsPrice & colOrder & ActiveRow) = Val(Me.lblAmoCalc)
            Else
                Range(wsPrice & colOrder & ActiveRow) = Val(Me.lblAmoCalc)
            End If
        Else
            Range(wsPrice & colOrder & ActiveRow) = ""
        End If
        Unload Me
    Else
        MsgBox "Введённое количество не соответсвует минимальным упаковкам. Пожалуйста измените количество и повторите ввод." & vbNewLine & "Вы можете использовать кнопки [+] и [-] или предложенный список вариантов под полем ввода.", vbInformation
    End If
End Sub

'============================================================

Private Sub btnCancel_Click()
    Unload Me
End Sub

Private Sub btnCancelKeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 39 Then
…