Менеджер классификаторов на 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 (
)
)
Link to this page:
//www.vb-net.com/wanted/VB6class/index.htm
|
|