Демонстрация работы с SLS-Active Склад из Excel

Для демонстрации работы с системой SLS-Active Склад приведем пример макроса для получения прайс-листа по группе товаров в Microsoft Excel .

 

Разумеется, получать прайс-листы легче и быстрее прямо из системы SLS-Склад. Считывание информации из базы данных системы SLS-Склад производится путем обращения к интерфейсам, предоставляемым системой SLS-Active Склад.

 

Данный макрос служит лишь для демонстрации работы с SLS-Active Склад на простом примере. Ниже приведен текст макроса с пояснениями для печати из Microsoft Excel прайс-листа по группе товаров.

 

Dim h, v, Vmax, Page, StartLineH, StartLineV, FontSize
Dim AxLoader, AxSklad, AxSession, SelPriceLists, TopGrName
Dim SelCards, PList, PosNum, IntfWSHNum
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'вывод отладочной информации о числе ссылок на интерфейсы
Sub IntfInfo(N, h)
Dim IntfNum, i
     IntfNum = AxLoader.GetMaxIntfNum
     For i = 1 To IntfNum
          Worksheets(N).Cells(i, h).Value = AxLoader.GetIntfName(i) + " : " + CStr(AxLoader.GetIntfCount(i))
     Next
End Sub

'
'функция печати информации по позиции прайс-листа
Sub PrintPos(GAdr, Pos, Title)
Dim Sel
    'отберем карточки товаров и группы товаров из группы с адресом GAdr
    Set Sel = AxSession.SelectData("Rec_cards", GAdr, 0)
    'перейдем в списке отобранных записей к позиции Pos
    Sel.Position = Pos
    first = True
    'цикл по всем отобранным записям
    While Not Sel.EOF
          If Sel.GetFieldAsInteger("cardtyp", 0) = 1 Then
          'группа карточек товаров
             'сформируем параметры для вызова рекурсии
             iGAdr = Sel.Address
             iPos = 0
             'сохраним текущую позицию в списке
             curPos = Sel.Position
             'сформируем заголовок подгруппы
             iTitle = Title + " *** " + Sel.GetFieldAsString("ntovar", 0)
             'уничтожим ссылку на интерфейс, чтобы во время рекурсии
             'не занимать лишнюю память
             Set Sel = Nothing
             'рекурсивный вызов для найденной группы
             Call PrintPos(iGAdr, iPos, iTitle)
             'после рекурсии восстановим список
             'и встанем на нужную позицию
             Set Sel = AxSession.SelectData("Rec_cards", GAdr, 0)
             Sel.Position = curPos
          Else
          'запись карточки товара
             If first = True Then
             'надо писать заголовок группы
                   Page.Range(Page.Cells(StartLineH + h, StartLineV), Page.Cells(StartLineH + h, StartLineV + Vmax)).Merge
                   Page.Range(Page.Cells(StartLineH + h, StartLineV), Page.Cells(StartLineH + h, StartLineV + Vmax)).HorizontalAlignment = xlHAlignCenter
                   Page.Range(Page.Cells(StartLineH + h, StartLineV), Page.Cells(StartLineH + h, StartLineV + Vmax)).Font.Size = FontSize
                   Page.Range(Page.Cells(StartLineH + h, StartLineV), Page.Cells(StartLineH + h, StartLineV + Vmax)).Font.Bold = True
                   Page.Range(Page.Cells(StartLineH + h, StartLineV), Page.Cells(StartLineH + h, StartLineV + Vmax)).Value = Title
                   h = h + 1
                   first = False
             End If
             'заполняем строку с информацией и ценами по текущей записи товара
             Page.Cells(StartLineH + h, StartLineV + v).Value = PosNum
             PosNum = PosNum + 1
             v = v + 1
             Page.Cells(StartLineH + h, StartLineV + v).Value = Sel.GetFieldAsString("ntovar", 0)
             v = v + 1
             Page.Cells(StartLineH + h, StartLineV + v).Value = Sel.GetFieldAsString("nomnum", 0)
             v = v + 1
             Page.Cells(StartLineH + h, StartLineV + v).Value = Sel.GetFieldAsString("ediz", 0)
             v = v + 1
             'цены
             For i = 1 To 5
                  If PList.NotEmpty(i) Then
                     Page.Cells(StartLineH + h, StartLineV + v).Value = PList.CountGoodsPrice(Sel.Address, i, 10)
                     v = v + 1
                  End If
             Next
             v = 0
             h = h + 1
          End If
          'перейдем к следующей записи
          Sel.Next
    Wend
    Set Sel = Nothing
End Sub

Sub PriceList()
'''''''''''''''''
'PriceList Макрос
'''''''''''''''''
On Error Resume Next
StartLineH = 7
StartLineV = 1
headH0 = 20
headH = 28
numW = 3
namesW = 40
namesH = 25
nomnumW = 12
edizW = 5
FontSize = 10
FontName = "Times New Roman Cyr"
Halign = xlHAlignLeft
Valign = xlVAlignCenter

Set Page = ActiveSheet
'Очистим лист
Page.UsedRange.Clear
'Ввод данных
PriceListNom = InputBox("Введите номер прайс-листа:", "Номер прайс-листа", 3)
GroupAdr = InputBox("Введите адрес группы товаров:", "Группа товаров", 71228)
IntfWSHNum = CInt(InputBox("Введите адрес листа для вывода информации о кол-ве интерфейсов:", "Отладочная информация", Page.Index + 1))
Worksheets(IntfWSHNum).UsedRange.Clear

'получим указатель на главный интерфейс пакета SLS-ActiveСклад
Set AxLoader = CreateObject("SLSSklad.AxLoader")
If Err.Number = 0 Then
'все хорошо, попробуем подключиться к базе
      AxLoader.OpenDatabase ("c:\skladdbx\base.dbx")
      If Err.Number = 0 Then
         MsgBox "Все ОК!"
         'все хорошо, получим указатель на интерфейс AxSklad
         Set AxSklad = AxLoader.AxSklad
         'попробуем авторизовать пользователя
         If AxSklad.Login("Login", "Password", "") Then
              'все хорошо, получим указатель на AxSession
              Set AxSession = AxSklad.AxSession
              'отберем записи прайс-листов
              Set SelPriceLists = AxSession.SelectData("Rec_Pricel", 0, 0)
              'попробуем найти прайс-лист с указанным пользователем номером
              If SelPriceLists.GetPriceListByNom(PriceListNom) Then
                 'нашли, получим указатель на интрефейс для
                 'работы с прайс-листом AxPriceList
                 Set PList = SelPriceLists.GetPriceList
                 If Err.Number <>0 Then
                        MsgBox (Err.Description)
                 Else
                        FlgOk = True
                 End If
              Else
              'нет такого прайс-листа
                  FlgOk = False
                  MsgBox ("Нет прайс-листа с таким номером!")
              End If
              If FlgOk Then
                  'отберем карточки и группы товаров,
                  'лежащие в группе с адресом GroupAdr
                  Set SelCards = AxSession.SelectData("REC_CARDS", GroupAdr, 0)
                  If Err.Number = 0 Then
                      'вызовем процедуру печати отладочной информации
                      'о количестве ссылок на интерфейсы
                      Call IntfInfo(IntfWSHNum, 1)
                      'теперь займемся оформлением заголовка нашего прайс-листа
                      h = 0
                      v = 0
                      Page.Cells(StartLineH + h, StartLineV + v).Value = "№ п/п"
                      Page.Range(Page.Cells(StartLineH + h, StartLineV + v),      Page.Cells(StartLineH + h + 1, StartLineV + v)).Merge
                      Page.Columns(StartLineV + v).ColumnWidth = numW
                      Page.Columns(StartLineV + v).HorizontalAlignment = xlHAlignRight
                      Page.Cells(StartLineH + h, StartLineV + v).HorizontalAlignment = xlHAlignCenter
                      v = v + 1
                      Page.Cells(StartLineH + h, StartLineV + v).Value = "Наименование товара"
                      Page.Range(Page.Cells(StartLineH + h, StartLineV + v),       Page.Cells(StartLineH + h + 1, StartLineV + v)).Merge
                      Page.Columns(StartLineV + v).ColumnWidth = namesW
                      Page.Columns(StartLineV + v).HorizontalAlignment = xlHAlignLeft
                      Page.Cells(StartLineH + h, StartLineV + v).HorizontalAlignment = xlHAlignCenter
                      v = v + 1
                      Page.Cells(StartLineH + h, StartLineV + v).Value = "Номенклатурный номер"
                      Page.Range(Page.Cells(StartLineH + h, StartLineV + v),          Page.Cells(StartLineH + h + 1, StartLineV + v)).Merge
                      Page.Columns(StartLineV + v).ColumnWidth = nomnumW
                      Page.Columns(StartLineV + v).HorizontalAlignment = xlHAlignLeft
                      Page.Columns(StartLineV + v).NumberFormat = "@"
                      Page.Cells(StartLineH + h, StartLineV + v).HorizontalAlignment = xlHAlignCenter
                      v = v + 1
                      Page.Cells(StartLineH + h, StartLineV + v).Value = "Ед. изм."
                      Page.Range(Page.Cells(StartLineH + h, StartLineV + v), Page.Cells(StartLineH + h + 1, StartLineV + v)).Merge
                      Page.Columns(StartLineV + v).ColumnWidth = edizW
                      Page.Columns(StartLineV + v).HorizontalAlignment = xlHAlignCenter
                      Page.Cells(StartLineH + h, StartLineV + v).HorizontalAlignment = xlHAlignCenter
                      v = v + 1
                      Page.Cells(StartLineH + h, StartLineV + v).Value = "Цены на " + CStr(Date)
                      Page.Cells(StartLineH + h, StartLineV + v).HorizontalAlignment = xlHAlignCenter
                      h = h + 1
                      Vmin = v
                      Page.Rows(StartLineH + h).RowHeight = headH
                      For i = 1 To 5
                          If PList.NotEmpty(i) Then
                               Page.Cells(StartLineH + h, StartLineV + v).Value = PList.GetPriceField(i, "fname") + " " + PList.GetPriceField(i, "iUSD")
                               Page.Columns(StartLineV + v).HorizontalAlignment = xlHAlignRight
                               Page.Cells(StartLineH + h, StartLineV + v).HorizontalAlignment = xlHAlignCenter
                               v = v + 1
                          End If
                      Next
                      Vmax = v - 1
                      Page.Range(Page.Cells(StartLineH + h - 1, StartLineV + Vmin), Page.Cells(StartLineH + h - 1, StartLineV + Vmax)).Merge
                      Page.Range(Page.Cells(StartLineH + h - 1, StartLineV + Vmin), Page.Cells(StartLineH + h - 1, StartLineV + Vmax)).HorizontalAlignment = xlHAlignCenter
                      'Верхний заголовок
                      Page.Range(Page.Cells(StartLineH - 2, StartLineV), Page.Cells(StartLineH - 2, StartLineV + Vmax)).Merge
                      Page.Range(Page.Cells(StartLineH - 2, StartLineV), Page.Cells(StartLineH - 2, StartLineV + Vmax)).HorizontalAlignment = xlHAlignCenter
                      Page.Range(Page.Cells(StartLineH - 2, StartLineV), Page.Cells(StartLineH - 2, StartLineV + Vmax)).Font.Size = FontSize
                      Page.Range(Page.Cells(StartLineH - 2, StartLineV), Page.Cells(StartLineH - 2, StartLineV + Vmax)).Value = SelPriceLists.GetFieldAsString("poisn", 0)

                      Page.Range(Page.Cells(StartLineH - 4, StartLineV), Page.Cells(StartLineH - 4, StartLineV + Vmax)).Merge
                      Page.Range(Page.Cells(StartLineH - 4, StartLineV), Page.Cells(StartLineH - 4, StartLineV + Vmax)).HorizontalAlignment = xlHAlignCenter
                      Page.Range(Page.Cells(StartLineH - 4, StartLineV), Page.Cells(StartLineH - 4, StartLineV + Vmax)).Font.Size = 16
                      Page.Range(Page.Cells(StartLineH - 4, StartLineV), Page.Cells(StartLineH - 4, StartLineV + Vmax)).Font.Bold = True
                      Page.Range(Page.Cells(StartLineH - 4, StartLineV), Page.Cells(StartLineH - 4, StartLineV + Vmax)).Value = SelPriceLists.GetFieldAsString("printname", 0)

                      h = h + 1
                      v = 0
                      'определим название группы с адресом GroupAdr
                      Dim TopGrSel
                      If SelCards.GetFieldAsInteger("adrgrp", 0) = 0 Then
                      'это группа верхнего уровня
                            Set TopGrSel = AxSession.SelectData("Rec_Cards", 0, 0)
                            TopGrSel.Address = GroupAdr
                            TopGrName = TopGrSel.GetFieldAsString("name", 0)
                            Set TopGrSel = Nothing
                      Else
                      'это группа второго или выше уровня
                            Set TopGrSel = AxSession.SelectData("Rec_Cards", -1, 0)
                            TopGrSel.Address = GroupAdr
                            TopGrName = TopGrSel.GetFieldAsString("ntovar", 0)
                            Set TopGrSel = Nothing
                      End If
                      Page.Range(Page.Cells(StartLineH - 3, StartLineV), Page.Cells(StartLineH - 3, StartLineV + Vmax)).Merge
                      Page.Range(Page.Cells(StartLineH - 3, StartLineV), Page.Cells(StartLineH - 3, StartLineV + Vmax)).HorizontalAlignment = xlHAlignCenter
                      Page.Range(Page.Cells(StartLineH - 3, StartLineV), Page.Cells(StartLineH - 3, StartLineV + Vmax)).Font.Size = 18
                      Page.Range(Page.Cells(StartLineH - 3, StartLineV), Page.Cells(StartLineH - 3, StartLineV + Vmax)).Font.Bold = True
                      Page.Range(Page.Cells(StartLineH - 3, StartLineV), Page.Cells(StartLineH - 3, StartLineV + Vmax)).Value = TopGrName
                      Dim G_Param
                      'определим название организации
                      Set G_Param = AxSession.SelectData("G1_param", 0, 0)
                      Page.Range(Page.Cells(StartLineH - 5, StartLineV), Page.Cells(StartLineH - 5, StartLineV + Vmax)).Merge
                      Page.Range(Page.Cells(StartLineH - 5, StartLineV), Page.Cells(StartLineH - 5, StartLineV + Vmax)).HorizontalAlignment = xlHAlignLeft
                      Page.Range(Page.Cells(StartLineH - 5, StartLineV), Page.Cells(StartLineH - 5, StartLineV + Vmax)).Font.Size = FontSize
                      Page.Range(Page.Cells(StartLineH - 5, StartLineV), Page.Cells(StartLineH - 5, StartLineV + Vmax)).Font.Bold = True
                      Page.Range(Page.Cells(StartLineH - 5, StartLineV), Page.Cells(StartLineH - 5, StartLineV + Vmax)).Value = G_Param.GetFieldAsString("Nameshort", 0)
                      Set G_Param = Nothing
                      PosNum = 1
                      'выведем информацию по позициям прайс-листа
                      Call PrintPos(GroupAdr, 0, TopGrName)
                      'теперь все красиво оформим: рамочки и т.п.
                      With Page.UsedRange
                             .Font.Name = FontName
                             .VerticalAlignment = Valign
                             .WrapText = True
                      End With
                      With Page.Range(Page.Cells(StartLineH, StartLineV), Page.Cells(StartLineH + h - 1, StartLineV + Vmax))
                             .Borders.LineStyle = xlContinuous
                             .Borders.Weight = xlThin
                             .Font.Size = FontSize
                      End With
                      Page.PageSetup.PrintTitleRows = Page.Range(Page.Rows(StartLineH), Page.Rows(StartLineH + 1)).Rows.Address
                      'уничтожим ссылки на интерфесы, которые еще есть
                      Set SelCards = Nothing
                      Set PriceLists = Nothing
                      Set PList = Nothing
             Else
                  FlgOk = False
                  MsgBox ("Плохой адрес группы товаров!")
             End If
             Set SelCards = Nothing
         End If
         Set PList = Nothing
         Set SelPriceLists = Nothing
         Set AxSession = Nothing
     Else
         MsgBox ("Логин не прошел!")
     End If
     Set AxSklad = Nothing
     'закроем подключение к базе
     'это нужно делать ТОЛЬКО, если успешно
     'прошел AxLoader.OpenDatabase ("...."),
     'иначе будут ошибки!!!
     AxLoader.CloseWorkSession
  Else
     MsgBox ("К базе не подключились!")
  End If
Else
    MsgBox ("Loader не создался!")
End If
'перед закрытием SLS-ActiveСклада проверим, все ли
'ссылки на интерфейсы мы уничтожили
'Если остаются неуичтоженные ссылки - очень плохо, т.к.
'не освобождаем память, нужно найти и поправить.
Call IntfInfo(IntfWSHNum, 5)
Set AxLoader = Nothing
End Sub