Менеджер классификаторов на VB6

На этой страничке я скажу об одной своей проге, которую я ковырял (периодически возвращаясь к ней) в течении полугода. Это менеджер классификаторов. К сожалению, работодатель, несмотря на все мои попытки переубедить его, настоял на возможности загружать в базу рисунков произвольных размеров, поэтому внешний вид этой проги получился не ахти-какой, ибо шестерочные комбешники растягивают рисунки по ширине максимального рисунка.

А вообще-то в этой проге немало интересных находок применено. Да и структура данных у нее непростая. Вот лишь один ее фрагмент:

Основных обьектов в базе у меня получилось 118 - таблиц и процедур:

Основная идея архитектуры - что классифаторы всех типов хранятся в одной табле и у отдельных классификаторов нет явного списка групп. Хотя погруппы ссылаются на группы. Процедуры в такой структуре получились все - крученные-перекрученные, примерно такого плана:

Основная идея на уровне VB6 - эмуляция АДО.НЕТ под шестеркой. Те полное отсоединенное назначение классификаторов в памяти в мультипользовательским режиме записью в базу только окончательного результата. Для типизации записи классификатора я определил его структуру до компиляции в отдельной библиотеке:

Что позволило манипулировать в бейсики колеекцией в ТИПИЗИРОВАННОМ ВИДЕ, примерно вот так:

00001: VERSION 5.00
00002: Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
00003: Object = "{CB2CEF1C-C8B3-4185-B4BA-085994E2203B}#1.0#0"; "SPctlib_sva2.ocx"
00004: Begin VB.UserControl PR_Class 
00005:    ClientHeight    =   6075
00006:    ClientLeft      =   0
00007:    ClientTop       =   0
00008:    ClientWidth     =   9255
00009:    ScaleHeight     =   6075
00010:    ScaleWidth      =   9255
00011:    Begin SVA.ImCombo ImCombo2 
00012:       Height          =   375
00013:       Left            =   5160
00014:       TabIndex        =   12
00015:       Top             =   360
00016:       Width           =   3975
00017:       _ExtentX        =   7011
00018:       _ExtentY        =   661
00019:    End
00020:    Begin VB.CommandButton btAddOne 
00021:       Caption         =   "<"
00022:       Height          =   375
00023:       Left            =   4320
00024:       TabIndex        =   7
00025:       Top             =   2160
00026:       Width           =   495
00027:    End
00028:    Begin VB.CommandButton btAddAll 
00029:       Caption         =   "<<"
00030:       Height          =   375
00031:       Left            =   4320
00032:       TabIndex        =   6
00033:       Top             =   2520
00034:       Width           =   495
00035:    End
00036:    Begin VB.CommandButton btDelOne 
00037:       Caption         =   ">"
00038:       Height          =   375
00039:       Left            =   4320
00040:       TabIndex        =   5
00041:       Top             =   2880
00042:       Width           =   495
00043:    End
00044:    Begin VB.CommandButton btDelAll 
00045:       Caption         =   ">>"
00046:       Height          =   375
00047:       Left            =   4320
00048:       TabIndex        =   4
00049:       Top             =   3240
00050:       Width           =   495
00051:    End
00052:    Begin VB.CommandButton btFind 
00053:       Height          =   375
00054:       Left            =   4320
00055:       Picture         =   "PR_Class.ctx":0000
00056:       Style           =   1  'Graphical
00057:       TabIndex        =   3
00058:       Top             =   1800
00059:       Width           =   495
00060:    End
00061:    Begin VB.CommandButton btEditAllClass 
00062:       Caption         =   "Edit"
00063:       Height          =   375
00064:       Left            =   8040
00065:       TabIndex        =   2
00066:       Top             =   0
00067:       Width           =   540
00068:    End
00069:    Begin VB.CommandButton btNewClass 
00070:       Caption         =   "New"
00071:       Height          =   375
00072:       Left            =   8640
00073:       TabIndex        =   1
00074:       Top             =   0
00075:       Width           =   525
00076:    End
00077:    Begin VB.CommandButton btEditSignClass 
00078:       Caption         =   "Edit"
00079:       Height          =   375
00080:       Left            =   3480
00081:       TabIndex        =   0
00082:       Top             =   0
00083:       Width           =   540
00084:    End
00085:    Begin MSComctlLib.ImageList ILType 
00086:       Left            =   4320
00087:       Top             =   5160
00088:       _ExtentX        =   1005
00089:       _ExtentY        =   1005
00090:       BackColor       =   -2147483643
00091:       MaskColor       =   12632256
00092:       _Version        =   393216
00093:    End
00094:    Begin MSComctlLib.ImageList ILClass 
00095:       Left            =   4320
00096:       Top             =   4560
00097:       _ExtentX        =   1005
00098:       _ExtentY        =   1005
00099:       BackColor       =   -2147483643
00100:       MaskColor       =   12632256
00101:       _Version        =   393216
00102:    End
00103:    Begin SPctlib_sva2.FlexGridST grYes 
00104:       Height          =   5655
00105:       Left            =   0
00106:       TabIndex        =   8
00107:       Top             =   360
00108:       Width           =   4005
00109:       _ExtentX        =   7064
00110:       _ExtentY        =   9975
00111:       DisableDblClkRefresh=   -1  'True
00112:    End
00113:    Begin SPctlib_sva2.FlexGridST grAll 
00114:       Height          =   5295
00115:       Left            =   5160
00116:       TabIndex        =   9
00117:       Top             =   720
00118:       Width           =   4005
00119:       _ExtentX        =   7064
00120:       _ExtentY        =   9340
00121:       DisableDblClkRefresh=   -1  'True
00122:    End
00123:    Begin VB.Label Label10 
00124:       Caption         =   "Все классификаторы"
00125:       ForeColor       =   &H8000000D&
00126:       Height          =   255
00127:       Left            =   5160
00128:       TabIndex        =   11
00129:       Top             =   120
00130:       Width           =   1815
00131:    End
00132:    Begin VB.Label Label11 
00133:       BackColor       =   &H8000000B&
00134:       Caption         =   "Назначенные классификаторы"
00135:       ForeColor       =   &H8000000D&
00136:       Height          =   255
00137:       Left            =   0
00138:       TabIndex        =   10
00139:       Top             =   120
00140:       Width           =   3975
00141:    End
00142:    Begin VB.Image ImageAll 
00143:       Height          =   240
00144:       Left            =   4440
00145:       Picture         =   "PR_Class.ctx":014A
00146:       Top             =   4320
00147:       Visible         =   0   'False
00148:       Width           =   240
00149:    End
00150: End
00151: Attribute VB_Name = "PR_Class"
00152: Attribute VB_GlobalNameSpace = False
00153: Attribute VB_Creatable = True
00154: Attribute VB_PredeclaredId = False
00155: Attribute VB_Exposed = False
00156: 'Instr=1 Arg1=ID - редактировать карточку
00157: 'Instr=2 (Arg1=ModelName - необязательно) - создать карточку
00158: '
00159: Dim OneRow As OneClassifierRowType.OneClassifierRow     'этот тип определен в отдельной внешней библиотеке
00160: Dim All As New Collection
00161: Dim Yes As New Collection
00162: Dim CurrAll_index As Long
00163: Dim CurrYes_index As Long
00164: '
00165: Dim RS As ADODB.Recordset
00166: '
00167: Private Enum Cl_Type
00168:     IsBrend = 1
00169:     IsMagazin = 2
00170:     IsKategory = 3
00171:     IsSubGroup = 4
00172:     IsDetails = 5
00173:     isAll = 6
00174: End Enum
00175: '
00176: Private C2_Key As New ArrayList   'ключ классификатора в Combo2
00177: Private C2_Type As New ArrayList   'тип классификатора в Combo2
00178: Private CurrentType As Cl_Type      'текущий тип классификатора, выбранный юзером в Combo2
00179: 
00180: Private PricePos As Long
00181: Private PriceNam As String
00182: 
00183: '************************************************************************
00184: 'Этот метод и событие - влияние категории в заголовке на сетку и наоборот
00185: '************************************************************************
00186: Public Event CategoryChanged(CategoryID As Long)
00187: 
00188: Public Sub SetNewCategoryID(CategoryID As Long)
00189: Dim i As Long
00190: 'сначала удаляем все категории из YES (и вернем их в ALL)
00191: For i = Yes.Count To 1 Step -1
00192:     If Yes(i).IsKategory Then
00193:        OneRow = Yes(i)
00194:        Yes.Remove (i)
00195:        All.Add OneRow
00196:     End If
00197: Next
00198: 'теперь добавим указанную (и удалим ее из ALL)
00199: For i = All.Count To 1 Step -1
00200:     If All(i).ID = CategoryID Then
00201:        OneRow = All(i)
00202:        All.Remove (i)
00203:        Yes.Add OneRow
00204:     End If
00205: Next
00206: grYes.Refresh
00207: grAll.Refresh
00208: End Sub
00209: 
00210: Private Sub CheckCategory()
00211: Dim i As Long, j As Long, k As Long
00212: For i = Yes.Count To 1 Step -1
00213:     If Yes(i).IsKategory Then
00214:         j = j + 1
00215:         k = i
00216:     End If
00217: Next i
00218: Select Case j
00219:     Case 0
00220:         RaiseEvent CategoryChanged(0)
00221:     Case 1
00222:         RaiseEvent CategoryChanged(Yes(k).ID)
00223:     Case Else
00224:         RaiseEvent CategoryChanged(0)
00225: End Select
00226: 
00227: End Sub
00228: 
00229: '*******************************************************************
00230: 'Эти свойства задают позицию прайс-листа, с которой работает контрол
00231: '*******************************************************************
00232: Public Property Get PricePosition() As Long
00233: PricePosition = PricePos
00234: End Property
00235: 
00236: Public Property Let PricePosition(i As Long)
00237: PricePos = i
00238: End Property
00239: 
00240: Public Property Get PriceName() As String
00241: PriceName = PriceNam
00242: End Property
00243: 
00244: Public Property Let PriceName(Name As String)
00245: PriceNam = Name
00246: End Property
00247: 
00248: 'какую-часть этой инициализации можно вынести отдельно по клику на TАБа, а какую-то оставить на общую загузку формы
00249: Public Sub Loading()
00250: LB_Monitor.MessageOn "Загрузка...", 1, 0
00251: 'сначала все картинки перегрузим из базы в Imagelist контрола
00252: Dim x As IImage
00253: Set RS = SPr("PR_GetAllClassifier")
00254: While Not RS.EOF
00255:     SY_ImageLib.AddImageFromSqlToImagelist ILClass, RS("ImageKey"), RS("Image")
00256:     'исключить дублирование
00257:     For Each x In ILType.ListImages
00258:         If x.Key = RS("TypeKey") Then GoTo NextRecord
00259:     Next
00260:     SY_ImageLib.AddImageFromSqlToImagelist ILType, RS("TypeKey"), RS("TypeImage")
00261: NextRecord:
00262:     RS.MoveNext
00263: Wend
00264: RS.Close
00265: '
00266: 'загрузим ImageCombo фильтрации классификаторов
00267: Dim DefaultKey As String
00268: Set RS = SPr("PR_GetTypeImages")
00269: 'ImCombo2.ComboImageClear
00270: 'ImCombo2.ComboItemClear
00271: C2_Key.Clear
00272: C2_Type.Clear
00273: ImCombo2.ComboImageAddPicture "S0", ImageAll.Picture
00274: ImCombo2.ComboItemAdd "(все)", "S0", "S0"       'ну или просто какая-то отдельная иконка из ImageList
00275: C2_Key.Add "S0"
00276: C2_Type.Add Cl_Type.isAll
00277: While Not RS.EOF
00278:     ImCombo2.ComboImageAddPictureFromSQL RS("ImageKey"), RS("Image")
00279:     ImCombo2.ComboItemAdd RS("Name"), "S" & RS("id"), RS("ImageKey")
00280:         '
00281:         C2_Key.Add "S" & RS("id")
00282:         If RS("IsBrend") Then C2_Type.Add Cl_Type.IsBrend
00283:         If RS("IsDetails") Then C2_Type.Add Cl_Type.IsDetails
00284:         If RS("IsKategory") Then C2_Type.Add Cl_Type.IsKategory
00285:         If RS("IsSubGroup") Then C2_Type.Add Cl_Type.IsSubGroup
00286:         If RS("IsMagazin") Then
00287:             C2_Type.Add Cl_Type.IsMagazin
00288:             DefaultKey = "S" & RS("id")
00289:             CurrentType = IsMagazin
00290:         End If
00291:     RS.MoveNext
00292: Wend
00293: RS.Close
00294: ImCombo2.ComboItemSetKey DefaultKey
00295: '
00296: 'теперь загрузим структуру сеток
00297: Call SetStructureSTGrid1(grAll, "PR_ST_Classifier", Nothing, 170)
00298: Call SetStructureSTGrid1(grYes, "PR_ST_Classifier", Nothing, 171)
00299: '
00300: 'тк редактирование не напрямую по базе - сначала считаем все классификаторы в массив
00301: Set RS = SPr("PR_GetAllClassifier")
00302: Fill_Collection All, RS
00303: '
00304: Call Init
00305: LB_Monitor.MessageOff
00306: End Sub
00307: 
00308: Public Sub ReplaceSignClassifier(ClassID As Long)
00309: For i = Yes.Count To 1 Step -1
00310:     If Yes(i).ID = ClassID Then
00311:         Yes.Remove (i)
00312:         Exit For
00313:      End If
00314: Next
00315: Set RS = SPr("PR_GetOneClassifier", "@i", ClassID)
00316: 'проверяем, что новая иконка загружена
00317: Dim x As IImage
00318: For Each x In ILType.ListImages
00319:     If x.Key = RS("ImageKey") Then GoTo Fill
00320: Next
00321: SY_ImageLib.AddImageFromSqlToImagelist ILClass, RS("ImageKey"), RS("Image")
00322: Fill: 'заполняем коллекцию и отображем ее
00323: Fill_Collection Yes, RS
00324: grYes.Refresh , CInt(ClassID)
00325: End Sub
00326: 
00327: Public Sub ReplaceAllClassifier(ClassID As Long)
00328: For i = All.Count To 1 Step -1
00329:     If All(i).ID = ClassID Then
00330:         All.Remove (i)
00331:         Exit For
00332:      End If
00333: Next
00334: Set RS = SPr("PR_GetOneClassifier", "@i", ClassID)
00335: 'проверяем, что новая иконка загружена
00336: Dim x As IImage
00337: For Each x In ILType.ListImages
00338:     If x.Key = RS("ImageKey") Then GoTo Fill
00339: Next
00340: SY_ImageLib.AddImageFromSqlToImagelist ILClass, RS("ImageKey"), RS("Image")
00341: Fill: 'заполняем коллекцию и отображем ее
00342: Fill_Collection All, RS
00343: grAll.Refresh , CInt(ClassID)
00344: End Sub
00345: 
00346: Public Sub AddClassifier(ClassID As Long)
00347: Set RS = SPr("PR_GetOneClassifier", "@i", ClassID)
00348: 'проверяем, что новая иконка загружена
00349: Dim x As IImage
00350: For Each x In ILType.ListImages
00351:     If x.Key = RS("ImageKey") Then GoTo Fill
00352: Next
00353: SY_ImageLib.AddImageFromSqlToImagelist ILClass, RS("ImageKey"), RS("Image")
00354: Fill: 'заполняем коллекцию и отображем ее
00355: Fill_Collection All, RS
00356: grAll.Refresh , CInt(ClassID)
00357: End Sub
00358: 
00359: Private Sub Init()
00360: 'теперь считаем УЖЕ назначенные ранее классификаторы и перенесем их в коллекцию Yes
00361: If FCE.Instr(UserControl.Parent) = 1 Then
00362:     'Instr=1 Arg1=ID - редактировать карточку
00363:     Set RS = SPr("PR_GetSignClassifier", "@i", FCE.Arg1(UserControl.Parent))
00364:     Fill_Collection Yes, RS
00365: Else
00366:     'Instr=2 (Arg1=ModelName - необязательно) - создать карточку
00367:     If Not IsMissing(FCE.Arg1(UserControl.Parent)) Then
00368:         Set RS = SPr("PR_FindClassifier_NewPosition", "@ModelName", FCE.Arg2(UserControl.Parent)) 'Автоподгруппы и автомагазины
00369:         Fill_Collection Yes, RS
00370:     End If
00371: End If
00372: '
00373: 'удалим элементы YES из ALL
00374: Dim OneRow1 As OneClassifierRowType.OneClassifierRow, i As Long, j As Long
00375: For j = Yes.Count To 1 Step -1
00376:     For i = All.Count To 1 Step -1
00377:         If Yes(j).ID = All(i).ID Then
00378:             All.Remove (i)
00379:         End If
00380:     Next
00381: Next
00382: '
00383: 'и заполним сетки
00384: grAll.CurrentTab = 1
00385: grYes.CurrentTab = 1
00386: End Sub
00387: 
00388: Private Sub Fill_Collection(ByRef c As Collection, RS As ADODB.Recordset)
00389: 'рекордсет уже заполнен снаружи
00390: If RS.Fields.Count = 0 Then Exit Sub
00391: While Not RS.EOF
00392:     OneRow.ID = RS("ID")
00393:     OneRow.Name = RS("Name")
00394:     OneRow.Image = RS("Image")
00395:     OneRow.ImageKey = RS("ImageKey")
00396:     OneRow.Description = DeNull(RS("Description"))
00397:     '
00398:     OneRow.Group = RS("Group")
00399:     OneRow.GroupImage = RS("GroupImage")
00400:     OneRow.GroupKey = RS("GroupKey")
00401:     OneRow.GroupName = RS("GroupName")
00402:     '
00403:     OneRow.Type = RS("Type")
00404:     OneRow.TypeImage = RS("TypeImage")
00405:     OneRow.TypeKey = RS("TypeKey")
00406:     OneRow.TypeName = RS("TypeName")
00407:     '
00408:     OneRow.IsBrend = RS("IsBrend")
00409:     OneRow.IsDetails = RS("IsDetails")
00410:     OneRow.IsKategory = RS("IsKategory")
00411:     OneRow.IsMagazin = RS("IsMagazin")
00412:     OneRow.IsSubGroup = RS("IsSubGroup")
00413:     '
00414:     c.Add OneRow
00415:     '
00416:     RS.MoveNext
00417: Wend
00418: RS.Close
00419: End Sub
00420: 
00421: Private Sub grAll_Changed(CurrentID As Long)
00422: If grAll.CurrentID = -1 Then
00423:     btEditAllClass.Enabled = False
00424: Else
00425:     btEditAllClass.Enabled = True
00426: End If
00427: End Sub
00428: 
00429: Private Sub grAll_ReadCell(Code As String, Text As String, Pic As Object, ItemData As Long, Alignment As MSFlexGridLib.AlignmentSettings, ForeColor As stdole.OLE_COLOR, BackColor As stdole.OLE_COLOR, FontName As String, FontSize As Currency, FontBold As Boolean, FontItalic As Boolean, CheckBox As stdole.OLE_TRISTATE, ColumnTag As String, RealCol As Integer)
00430: Dim one As OneClassifierRowType.OneClassifierRow
00431: one = All(CurrAll_index)
00432: Select Case Code
00433: Case "id"
00434:      Text = one.ID
00435: Case "Name"
00436:      Text = one.Name
00437:      Set Pic = ILClass.ListImages(one.ImageKey).Picture
00438: Case "TypeName"
00439:      Text = one.TypeName
00440:      Set Pic = ILType.ListImages(one.TypeKey).Picture
00441: End Select
00442: End Sub
00443: 
00444: Private Sub grAll_NextRow(EOF As Boolean)
00445: If CurrAll_index = All.Count Then
00446:     EOF = True
00447: Else
00448:     'фильтрация по массиву
00449:     Dim i As Long
00450:     For i = CurrAll_index + 1 To All.Count
00451:         If (All(i).IsBrend And CurrentType = IsBrend) Or _
00452:            (All(i).IsDetails And CurrentType = IsDetails) Or _
00453:            (All(i).IsKategory And CurrentType = IsKategory) Or _
00454:            (All(i).IsMagazin And CurrentType = IsMagazin) Or _
00455:            (All(i).IsSubGroup And CurrentType = IsSubGroup) Or _
00456:            CurrentType = isAll Then
00457:            CurrAll_index = i
00458:            Exit Sub
00459:         End If
00460:     Next
00461:     EOF = True
00462: End If
00463: End Sub
00464: 
00465: Private Sub grAll_PrepareRowsList(EOF As Boolean)
00466: If All.Count = 0 Then
00467:     EOF = True
00468: Else
00469:     'фильтрация по массиву
00470:     Dim i As Long
00471:     For i = 1 To All.Count
00472:         If (All(i).IsBrend And CurrentType = IsBrend) Or _
00473:            (All(i).IsDetails And CurrentType = IsDetails) Or _
00474:            (All(i).IsKategory And CurrentType = IsKategory) Or _
00475:            (All(i).IsMagazin And CurrentType = IsMagazin) Or _
00476:            (All(i).IsSubGroup And CurrentType = IsSubGroup) Or _
00477:            CurrentType = isAll Then
00478:            CurrAll_index = i
00479:            Exit Sub
00480:         End If
00481:     Next
00482:     EOF = True
00483: End If
00484: End Sub
00485: 
00486: Private Sub grYes_Changed(CurrentID As Long)
00487: If grYes.CurrentID = -1 Then
00488: btEditSignClass.Enabled = False
00489: Else
00490: btEditSignClass.Enabled = True
00491: End If
00492: End Sub
00493: 
00494: 'Private Sub grAll_PrepareRowsList(EOF As Boolean)
00495: 'Select Case CurrentType
00496: 'Case Cl_Type.IsAll: grAll.RecSet = SPr("PR_GetAllClassifier")
00497: 'Case Cl_Type.IsBrend: grAll.RecSet = SPr("PR_GetAllClassifierForType", "@IsBrend", True)
00498: 'Case Cl_Type.IsDetails: grAll.RecSet = SPr("PR_GetAllClassifierForType", "@IsDetails", True)
00499: 'Case Cl_Type.IsKategory: grAll.RecSet = SPr("PR_GetAllClassifierForType", "@IsKategory", True)
00500: 'Case Cl_Type.IsMagazin: grAll.RecSet = SPr("PR_GetAllClassifierForType", "@IsMagazin", True)
00501: 'Case Cl_Type.IsSubGroup: grAll.RecSet = SPr("PR_GetAllClassifierForType", "@IsSubGroup", True)
00502: 'Case 0 'начальная инициализация до первого щелчка
00503: '    grAll.RecSet = SPr("PR_GetAllClassifierForType", "@IsMagazin", True)
00504: 'End Select
00505: 'End Sub
00506: 
00507: 'Private Sub grAll_ReadCell(Code As String, Text As String, Pic As Object, ItemData As Long, Alignment As MSFlexGridLib.AlignmentSettings, ForeColor As stdole.OLE_COLOR, BackColor As stdole.OLE_COLOR, FontName As String, FontSize As Currency, FontBold As Boolean, FontItalic As Boolean, CheckBox As stdole.OLE_TRISTATE, ColumnTag As String, RealCol As Integer)
00508: 'Text = DeNull(grAll.RecSet(Code))
00509: 'If Code = "Name" Then
00510: '   Set Pic = ILClass.ListImages(grAll.RecSet("ImageKey").Value).Picture
00511: 'End If
00512: 'If Code = "TypeName" Then
00513: '    Set Pic = ILType.ListImages(grAll.RecSet("TypeKey").Value).Picture
00514: 'End If
00515: 'End Sub
00516: '
00517: Private Sub grYes_ReadCell(Code As String, Text As String, Pic As Object, ItemData As Long, Alignment As MSFlexGridLib.AlignmentSettings, ForeColor As stdole.OLE_COLOR, BackColor As stdole.OLE_COLOR, FontName As String, FontSize As Currency, FontBold As Boolean, FontItalic As Boolean, CheckBox As stdole.OLE_TRISTATE, ColumnTag As String, RealCol As Integer)
00518: Dim one As OneClassifierRowType.OneClassifierRow
00519: one = Yes(CurrYes_index)
00520: Select Case Code
00521: Case "id"
00522:      Text = one.ID
00523: Case "Name"
00524:      Text = one.Name
00525:      On Error GoTo Err1
00526:      Set Pic = ILClass.ListImages(one.ImageKey).Picture
00527: Case "TypeName"
00528:      Text = one.TypeName
00529:      On Error GoTo err2
00530:      Set Pic = ILType.ListImages(one.TypeKey).Picture
00531: End Select
00532: Exit Sub
00533: Err1:
00534: MsgBox ("Ошибка. Рисунок <" & one.ImageKey & "> не найден в <" & ILClass.Name & ">.")
00535: Exit Sub
00536: err2:
00537: MsgBox ("Ошибка. Рисунок <" & one.ImageKey & "> не найден в <" & ILType.Name & ">.")
00538: Exit Sub
00539: End Sub
00540: 
00541: Private Sub grYes_NextRow(EOF As Boolean)
00542: If CurrYes_index = Yes.Count Then
00543:     EOF = True
00544: Else
00545:     CurrYes_index = CurrYes_index + 1
00546: End If
00547: End Sub
00548: 
00549: Private Sub grYes_PrepareRowsList(EOF As Boolean)
00550: If Yes.Count = 0 Then
00551:     EOF = True
00552: Else
00553:     CurrYes_index = 1
00554: End If
00555: End Sub
00556: 
00557: 'Private Sub grYes_PrepareRowsList(EOF As Boolean)
00558: 'grYes.RecSet = SPr("PR_GetAllClassifier")
00559: 'End Sub
00560: '
00561: 'Private Sub grYes_ReadCell(Code As String, Text As String, Pic As Object, ItemData As Long, Alignment As MSFlexGridLib.AlignmentSettings, ForeColor As stdole.OLE_COLOR, BackColor As stdole.OLE_COLOR, FontName As String, FontSize As Currency, FontBold As Boolean, FontItalic As Boolean, CheckBox As stdole.OLE_TRISTATE, ColumnTag As String, RealCol As Integer)
00562: 'Text = DeNull(grYes.RecSet(Code))
00563: 'If Code = "Name" Then
00564: '   Set Pic = ILClass.ListImages(grYes.RecSet("ImageKey").Value).Picture
00565: 'End If
00566: 'If Code = "TypeName" Then
00567: '    Set Pic = ILType.ListImages(grYes.RecSet("TypeKey").Value).Picture
00568: 'End If
00569: 'End Sub
00570: 
00571: Private Sub btNewClass_Click()
00572: FCE.mCall UserControl.Parent, "PR_ClassifierCard", 2, 2
00573: End Sub
00574: 
00575: Private Sub btEditAllClass_Click()
00576: FCE.mCall UserControl.Parent, "PR_ClassifierCard", 1, 4, grAll.CurrentID
00577: End Sub
00578: 
00579: Private Sub btEditSignClass_Click()
00580: FCE.mCall UserControl.Parent, "PR_ClassifierCard", 1, 3, grYes.CurrentID
00581: End Sub
00582: 
00583: Private Sub ImCombo2_Changes(Key As String)
00584: Dim i As Long, x As String
00585: For i = 0 To C2_Key.Count - 1
00586:     If C2_Key(i) = Key Then
00587:         CurrentType = C2_Type(i)
00588:         Exit For
00589:     End If
00590: Next
00591: grAll.Refresh
00592: End Sub
00593: 
00594: Private Sub btAddAll_Click()
00595: Dim i As Long
00596: For i = All.Count To 1 Step -1
00597:         OneRow = All(i)
00598:         All.Remove (i)
00599:         Yes.Add OneRow
00600: Next
00601: grAll.Refresh
00602: grYes.Refresh
00603: Call CheckCategory
00604: End Sub
00605: 
00606: Private Sub btAddOne_Click()
00607: Dim i As Long
00608: For i = All.Count To 1 Step -1
00609:     If grAll.CurrentID = All(i).ID Then
00610:         OneRow = All(i)
00611:         All.Remove (i)
00612:         Yes.Add OneRow
00613:         Exit For
00614:     End If
00615: Next
00616: grAll.Refresh
00617: grYes.Refresh
00618: Call CheckCategory
00619: End Sub
00620: 
00621: Private Sub btDelAll_Click()
00622: Dim i As Long
00623: For i = Yes.Count To 1 Step -1
00624:         OneRow = Yes(i)
00625:         Yes.Remove (i)
00626:         All.Add OneRow
00627: Next
00628: grAll.Refresh
00629: grYes.Refresh
00630: Call CheckCategory
00631: End Sub
00632: 
00633: Private Sub btDelOne_Click()
00634: Dim i As Long
00635: For i = Yes.Count To 1 Step -1
00636:     If grYes.CurrentID = Yes(i).ID Then
00637:         OneRow = Yes(i)
00638:         Yes.Remove (i)
00639:         All.Add OneRow
00640:         Exit For
00641:     End If
00642: Next
00643: grAll.Refresh
00644: grYes.Refresh
00645: Call CheckCategory
00646: End Sub
00647: 
00648: 'эту хрень можно позже модифицировать, чтоб ВСЕ-ВСЕ-ВСЕ отношения выставились ЗА ОДИН-ЕДИНСТВЕННЫЙ вызов процедуры
00649: 'типа как в .NET - сериализовать XML из коллекции YES и за один вызов отдать его процедуре
00650: Public Function SaveClassifierMM() As Boolean
00651: If PricePos = 0 Then
00652:     MsgBox ("Сохранение отношений с классификаторами невозможно - позиции прайс-листа не существует.")
00653: Else
00654:     Dim i As Long, Ret As Long, j As Long
00655:     'проверка на корректность сохраняемого набора классификаторов
00656:     For i = Yes.Count To 1 Step -1
00657:         If Yes(i).IsKategory Then
00658:             j = j + 1
00659:         End If
00660:     Next
00661:     Select Case j
00662:     Case 0
00663:         MsgBox ("Сохранение отношений с классификаторами невозможно - нет категории.")
00664:         SaveClassifierMM = False
00665:         '
00666:     Case 1
00667:         'вставили все новое
00668:         For i = Yes.Count To 1 Step -1
00669:             Ret = SPi("PR_SetClassifierMM", "@ToPrice", PricePos, "@ToClass", Yes(i).ID)
00670:         Next
00671:         'и удалили лишнее
00672:         Set RS = SPr("PR_GetSignClassifier", "@i", PricePos)
00673:         While Not RS.EOF
00674:             For i = Yes.Count To 1 Step -1
00675:                 If RS("ID") = Yes(i).ID Then GoTo present
00676:             Next
00677:             Ret = SPi("PR_DelClassifierMM", "@ToPrice", PricePos, "@ToClass", RS("id"))
00678: present:
00679:             RS.MoveNext
00680:         Wend
00681:         SaveClassifierMM = True
00682:         '
00683:     Case Else
00684:         MsgBox ("Сохранение отношений с классификаторами невозможно - более одной категории.")
00685:         SaveClassifierMM = False
00686:         '
00687:     End Select
00688: End If
00689: End Function
00690: 
00691: Private Sub btFind_Click()
00692: If (PriceNam = "") And (PricePos = 0) Then
00693:     MsgBox ("Нет ни имени позиции, ни ее номера - поиск невозможен")
00694: Else
00695:     'первый вызов для поиска групп/подгрупп, второй для всего остального
00696:     Call FindClassifier("PR_FindClassifier_SubGroup")
00697:     Call FindClassifier("PR_FindClassifier_Other")
00698: End If
00699: grYes.Refresh
00700: grAll.Refresh
00701: Call CheckCategory
00702: End Sub
00703: 
00704: Private Sub FindClassifier(ProcName As String)
00705: 'сериализовать все уже назначенное (из коллекции YES) и за один вызов отдать его процедуре
00706: Dim YesString As String
00707: YesString = ""
00708: For i = Yes.Count To 1 Step -1
00709:     YesString = YesString & Yes(i).ID & " "
00710: Next
00711: '
00712: If Not (PricePos = 0) Then
00713:     Set RS = SPr(ProcName, "@i", PricePos, "@Yes", YesString)
00714: Else
00715:     Set RS = SPr(ProcName, "@PriceName", PriceNam, "@Yes", YesString)
00716: End If
00717: '
00718: Dim FindResult As New Collection, j As Integer
00719: Fill_Collection FindResult, RS
00720: '
00721: 'перебросить в YES вновь найденные классификаторы
00722: For i = FindResult.Count To 1 Step -1
00723:     For j = Yes.Count To 1 Step -1
00724:         If Yes(j).ID = FindResult(i).ID Then GoTo NotAdding
00725:     Next j
00726:     'удалим из ALL
00727:     For j = All.Count To 1 Step -1
00728:         If All(j).ID = FindResult(i).ID Then All.Remove (j)
00729:     Next j
00730:     'и добавим в YES
00731:     Yes.Add FindResult(i)
00732: NotAdding:
00733: Next i
00734: End Sub

Таких форм у меня получилось в этой системе более двадцати:

В целом система после проведения импорта позволяет оценивать, какие позиции поставшиков привязаны к нашему прайсу, регулировать различные параметры выходного прайса, торговую наценку, и прочее.

Но, как уже говорилось - основная изюминка этой моей системы - развитая система управления классификацией прайсовых позиций, с легкостью позволяющей ориентироваться в прайсах, скажем в 25 тысяч наименований и позволяющая ровно в три щелчка выполнить такой, скажем отбор - "Фотоаппарат", "обьектив зеркальный", "цена до $300" - какие есть производители и какие поставщики по каким ценам это предлагаю. Для этого прайс разрезается в нескольких измерениях, как показано на рисунках ниже (тестовая база):

Comments ( )