MA Access | Примеры
|
Например, есть список активных клиентов по территориям и список менеджеров (продавцов) по территориям:
Например, требуется равномерно распределить базу клиентов между менеджерами, внутри каждой территории.
Пусть на территории 1 есть 7 клиентов и 3 менеджера.
Тогда равномерное распределение выглядело бы примерно так:
Одному менеджеру 3 клиента, второму 2, третьему 2:
Например, реализован следующий дизайн формы со списком клиентов и кнопками управления:
Под кнопку "Назначить менеджера клиенту" требуется разработать код равномерного распределения клиентов по менеджерам в цикле (заполнение полей формы SalesPersonID, SalesPersonName и также поля Error, если в процессе возникла ошибка).
По результатам распределения выдать окно сколько клиентов распределено успешно и сколько с ошибками:
Под кнопку "Открыть сводку распределения клиентов" требуется разработать код открытия формы -- сводной диаграммы по данным о клиентах и назначенных на них менеджеров:
Под кнопку "Очистить результат назначения" требуется убрать назначенных менеджеров (очистить поля на форме в цикле):
Равномерное распределение клиентов по менеджерам в цикле
Реализация равномерности с помощью запроса выдать менеджера по самой ранней дате LAST_ASSIGNED, где LAST_ASSIGNED -- дата и время назначения менеджеру очередного клиента (точность хранения времени одна сотая секунды):
SalesPerson_by_Territory_QRY --запрос -- список продавцов по территориям
PARAMETERS TerritoryID_PARAM Short; -- на заданное значение TerritoryID вернуть продавца с самой ранней датой LAST_ASSIGNED SELECT TOP 1 SalesPerson_TAB.SalesPersonID, SalesPerson_TAB.SalesPersonName, SalesPerson_TAB.Territory_ID, Territory_TAB.Territory_Name, SalesPerson_TAB.LAST_ASSIGNED FROM Territory_TAB INNER JOIN SalesPerson_TAB ON Territory_TAB.Territory_ID = SalesPerson_TAB.Territory_ID WHERE (((SalesPerson_TAB.Territory_ID)=[TerritoryID_PARAM])) ORDER BY SalesPerson_TAB.LAST_ASSIGNED;
LAST_ASSIGNED по каждому назначенному менеджеру помечается новым значением, при этом вызов процедуры Wait на заданное количество сотых секунды обеспечивает её уникальность.
Private Sub DISTRIBUTE_CUSTOMERS_Click() If Recordset.EOF Then 'рекордсет формы MsgBox "Нет записей", vbExclamation Else Recordset.MoveFirst Dim nSuccess As Integer 'количество успешно распределённых клиентов (назначен менеджер) Dim nError As Integer 'количество ошибок при распределении (не назначен менеджер) Do While Not Recordset.EOF 'до конца рекордсета If IsNull(Recordset!SalesPersonID) Then 'если клиенту менеджер ещё не назначен Recordset.Edit 'перевести текущую запись рекордсета в режим редактирования On Error GoTo Err 'при ошибке перейти к err: Dim SalesPersonID As Integer Dim SalesPersonName As String
'функция принимает TerritoryID и вычисляет SalesPersonID Call SalesPersonRoundRobin(Recordset!TerritoryID, SalesPersonID, SalesPersonName)
Recordset!SalesPersonID = SalesPersonID 'заполнить поле SalesPersonID значением переменной SalesPersonID Recordset!SalesPersonName = SalesPersonName 'заполнить поле SalesPersonName значением переменной SalesPersonName Recordset!ERROR = Null nSuccess = nSuccess + 1 'количество успешно распределённых дел + 1
GoTo OK 'продолжить в OK-е Err: 'заполнить поле формы "ERROR" если в процессе возникла ошибка Recordset!ERROR = CErr() 'CErr берёт текущий exception и делает из него строку nError = nError + 1 'количество ошибок при распределении + 1 Resume OK 'продолжить в OK-е (если не перейти в ОК, то ошибка на следующей итерации цикла вызовет переход в отладчик (Debug на экране)) OK: Recordset.Update End If Recordset.MoveNext Loop Me.Refresh 'обновить обновлённую последнюю запись на экране Recordset.MoveFirst If nSuccess = 0 And nError = 0 Then MsgBox "Распределение клиентов по менеджерам:", vbExclamation Else Dim status As Integer 'переменная вида сообщения пользователю на экран If nError = 0 Then status = vbInformation Else status = vbExclamation End If MsgBox "Распределение клиентов по менеджерам:" & vbCrLf _ & vbCrLf _ & "успешно: " & nSuccess & vbCrLf _ & "ошибочно: " & nError, _ status, softname End If End If End Sub
'процедура принимает TerritoryID и вычисляет SalesPersonID и SalesPersonName 'заполняет данные поля SalesPersonID и SalesPersonName в форме Sub SalesPersonRoundRobin(TerritoryID As Variant, ByRef SalesPersonID As Integer, ByRef SalesPersonName As String)
If IsNull(TerritoryID) Then 'если в текущей записи по какой-то причине нет значения TerritoryID Err.Raise 1, "Internal error", "TerritoryID must be filled in but is null" 'поднять exception End If
'изначальное значение SalesPersonID = 0 SalesPersonName = ""
Dim qdf As DAO.QueryDef
Set qdf = CurrentDb.QueryDefs!SalesPerson_by_Territory_QRY 'запрос -- список продавцов по территориям 'Запрос отдаёт того продавца (SalesPerson), у которого дата LAST_ASSIGNED самая старая (ему давно не передавали клиентов) 'Сделано с помощью вызова SELECT TOP 1 и сортировки по полю LAST_ASSIGNED '(дата LAST_ASSIGNED обновляется по ходу программы)
qdf.Parameters!TerritoryID_PARAM = TerritoryID 'в запросе SalesPerson_by_Territory_QRY параметр именован как TerritoryID_PARAM 'присваиваем ему значение из входящего параметра функции
Dim rs As DAO.Recordset Set rs = qdf.OpenRecordset 'выполнить запрос SalesPerson_by_Territory_QRY
'Check to see if the recordset actually contains rows If Not (rs.EOF And rs.BOF) Then SalesPersonName = rs!SalesPersonName 'найденный SalesPersonName (вернуть в параметр процедуры ByRef) SalesPersonID = rs!SalesPersonID 'найденный SalesPersonName (вернуть в параметр процедуры ByRef)
Wait 0.01 'обновляя дату LAST_ASSIGNED нельзя попасть в ту же долю секунды, т.к. точность хранения времени в LAST_ASSIGNED одна сотая секунды) rs.Edit 'переключить запись рекордсета в режим редактирования
'положить новое значение LAST_ASSIGNED в запрос SalesPerson_by_Territory_QRY rs!LAST_ASSIGNED = TimeInMS 'функция TimeInMS выдает строку системного времени в формате дата и время с точностью до сотых долей секунды rs.Update 'сохранить изменения End If
rs.Close 'закрыть рекордсет Set rs = Nothing 'очистить рекордсет qdf.Close 'закрыть запрос Set qdf = Nothing 'очистить переменную запроса
'в эту ситуацию можно провалиться из первого IF-а или если почему-то NULL-ы в запросе SalesPerson_by_Territory_QRY If SalesPersonName = "" Then Err.Raise 1, CErr End If End Sub
'выдает строку системного времени в формате дата и время с точностью до сотых долей секунды Public Function TimeInMS() As String TimeInMS = Strings.Format(now, "yyyy-mm-dd HH:nn:ss") & "." & Strings.Right(Strings.Format(Timer, "#0.00"), 2) End Function
Sub Wait(seconds As Single) Dim now As Long now = Timer() Do DoEvents Loop While (Timer < now + seconds) End Sub
Sub test() Dim a As String Dim b As String a = TimeInMS Wait (0.001) b = TimeInMS MsgBox a & " " & b End Sub
Public Function CErr() As String 'представляет ошибку программы / exception в виде строки CErr = "Error: " & CStr(Err.Number) & "; " & Err.Source & "; " & Err.Description 'например Error: 3421; DAO.Field; Ошибка преобразования типа данных. End Function
Скачать пример в zip: RecordsetCycleSample.zipСкачать пример в accdb: RecordsetCycleSample.accdb |