VERSION 5.00 Begin VB.Form frmSort Caption = "Code Mapper" ClientHeight = 6705 ClientLeft = 60 ClientTop = 345 ClientWidth = 9285 Icon = "frmSort.frx":0000 LinkTopic = "Form1" OLEDropMode = 1 'Manual ScaleHeight = 6705 ScaleWidth = 9285 StartUpPosition = 3 'Windows Default Begin VB.CommandButton cbCancel Cancel = -1 'True Caption = "&Cancel" BeginProperty Font Name = "Verdana" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 5625 TabIndex = 25 Top = 6285 Width = 1575 End Begin VB.CommandButton cbSave Caption = "&Save" BeginProperty Font Name = "Verdana" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 7305 TabIndex = 24 Top = 6285 Width = 1575 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 20 Left = 75 TabIndex = 21 TabStop = 0 'False Top = 5790 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 19 Left = 75 TabIndex = 20 TabStop = 0 'False Top = 5505 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 18 Left = 75 TabIndex = 19 TabStop = 0 'False Top = 5220 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 17 Left = 75 TabIndex = 18 TabStop = 0 'False Top = 4935 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 16 Left = 75 TabIndex = 17 TabStop = 0 'False Top = 4650 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 15 Left = 75 TabIndex = 16 TabStop = 0 'False Top = 4365 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 14 Left = 75 TabIndex = 15 TabStop = 0 'False Top = 4080 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 13 Left = 75 TabIndex = 14 TabStop = 0 'False Top = 3795 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 12 Left = 75 TabIndex = 13 TabStop = 0 'False Top = 3510 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 11 Left = 75 TabIndex = 12 TabStop = 0 'False Top = 3225 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 10 Left = 75 TabIndex = 11 TabStop = 0 'False Top = 2940 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 9 Left = 75 TabIndex = 10 TabStop = 0 'False Top = 2655 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 8 Left = 75 TabIndex = 9 TabStop = 0 'False Top = 2370 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 7 Left = 75 TabIndex = 8 TabStop = 0 'False Top = 2085 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 6 Left = 75 TabIndex = 7 TabStop = 0 'False Top = 1800 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 5 Left = 75 TabIndex = 6 TabStop = 0 'False Top = 1515 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 4 Left = 75 TabIndex = 5 TabStop = 0 'False Top = 1230 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 3 Left = 75 TabIndex = 4 TabStop = 0 'False Top = 945 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 2 Left = 75 TabIndex = 3 TabStop = 0 'False Top = 660 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 1 Left = 75 TabIndex = 2 TabStop = 0 'False Top = 375 Width = 8805 End Begin VB.CommandButton cbSort DragMode = 1 'Automatic BeginProperty Font Name = "Courier New" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 285 Index = 0 Left = 75 TabIndex = 1 TabStop = 0 'False Top = 90 Width = 8805 End Begin VB.VScrollBar VScroll1 Height = 6135 LargeChange = 10 Left = 8985 Max = 20 TabIndex = 0 Top = 60 Width = 270 End Begin VB.Timer Timer1 Interval = 500 Left = 7365 Top = 5295 End Begin VB.Label lblDragBottom DragMode = 1 'Automatic Height = 90 Left = 75 TabIndex = 23 Top = 6105 Width = 8805 End Begin VB.Label lblDragTop DragMode = 1 'Automatic Height = 90 Left = 75 TabIndex = 22 Top = 0 Width = 8805 End End Attribute VB_Name = "frmSort" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Type Items Sort As Long Kind As String Name As String Desc As String End Type Private inDragMode As Boolean Private CopyIndex As Integer Private ScrollTopItemIndex As Integer Private ScrollBottomItemIndex As Integer Private ItemMinIndex As Integer Private ItemMaxIndex As Integer Private boolScrollUp As Boolean Private boolScrollDown As Boolean Private boolTimerScrollUp As Boolean Private boolTimerScrollDown As Boolean Private LastScrollValue As Integer Private CodeMap() As Items Private CodeIndex As Long Private CodeInc As Integer Private Sub cbCancel_Click() Unload Me End Sub Private Sub cbSave_Click() Unload Me End Sub Private Sub Form_Load() Dim c As Integer Dim ln As String ' ' Rebuild Map of Code from SpaceNumber's ' RebuildCodeMap ' This sorts it too ' ' Load Code Map into form ' ItemMinIndex = 0 ItemMaxIndex = CodeIndex + 1 ScrollTopItemIndex = 0 ScrollBottomItemIndex = 20 frmSort.VScroll1.Min = ItemMinIndex frmSort.VScroll1.Max = ItemMaxIndex - ScrollBottomItemIndex If ItemMaxIndex < 20 Then For c = ItemMaxIndex + 1 To 20 frmSort.cbSort(c).Visible = False Next c ScrollBottomItemIndex = ItemMaxIndex frmSort.VScroll1.Visible = False End If ReDim Preserve CodeMap(ItemMaxIndex) CodeMap(ItemMaxIndex).Name = "End of File" DrawList DrawList inDragMode = False End Sub Private Sub ResetScroll() boolTimerScrollUp = False boolTimerScrollDown = False boolScrollUp = False boolScrollDown = False End Sub Private Sub cbSort_DragDrop(Index As Integer, Source As Control, X As Single, Y As Single) Dim SaveItem As Items Dim DropIndex As Integer Dim i As Integer Dim mError As Boolean Dim mItem As String If (Index = ScrollBottomItemIndex And ScrollBottomItemIndex = ItemMaxIndex) Or Index > ScrollBottomItemIndex Then Exit Sub End If inDragMode = False DropIndex = frmSort.cbSort(Index).Tag If CopyIndex <> DropIndex Then SaveItem = CodeMap(CopyIndex) mError = False Select Case True Case (SaveItem.Name = "Parser" Or SaveItem.Name = "VerbLib" Or SaveItem.Name = "Grammar") And SaveItem.Kind = "Include" mError = True mItem = SaveItem.Name Case SaveItem.Kind = "Release" mError = True mItem = "Release" Case SaveItem.Kind = "Serial" mError = True mItem = "Serial" Case SaveItem.Kind = "Switches" mError = True mItem = "Switches" End Select If mError Then MsgBox mItem & " is not a movable item.", , "Drag and Drop Sort" Exit Sub End If If CopyIndex > DropIndex Then For i = CopyIndex To DropIndex + 1 Step -1 CodeMap(i) = CodeMap(i - 1) Next i CodeMap(DropIndex) = SaveItem End If If CopyIndex < DropIndex Then For i = CopyIndex To DropIndex - 1 CodeMap(i) = CodeMap(i + 1) Next i CodeMap(DropIndex) = SaveItem End If DrawList End If ResetScroll End Sub Private Sub cbSort_DragOver(Index As Integer, Source As Control, X As Single, Y As Single, State As Integer) If (Index = ScrollBottomItemIndex And ScrollBottomItemIndex = ItemMaxIndex) Or Index > ScrollBottomItemIndex Then Exit Sub End If If Not inDragMode Then CopyIndex = frmSort.cbSort(Index).Tag inDragMode = True End If ResetScroll End Sub Private Sub DrawList() Dim c As Integer Dim i As Integer Dim ln As String c = -1 For i = ScrollTopItemIndex To ScrollBottomItemIndex c = c + 1 With frmSort.cbSort(c) ln = Pad(CodeMap(i).Kind, 12) & " " & _ Pad(CodeMap(i).Name, 28) & " " & _ Pad(CodeMap(i).Desc, 38) .Caption = ln .Tag = i End With Next i End Sub Private Sub lblDragBottom_DragDrop(Source As Control, X As Single, Y As Single) If (Index = ScrollBottomItemIndex And ScrollBottomItemIndex = ItemMaxIndex) Or Index > ScrollBottomItemIndex Then Exit Sub End If ResetScroll inDragMode = False End Sub Private Sub lblDragTop_DragDrop(Source As Control, X As Single, Y As Single) If (Index = ScrollBottomItemIndex And ScrollBottomItemIndex = ItemMaxIndex) Or Index > ScrollBottomItemIndex Then Exit Sub End If ResetScroll inDragMode = False End Sub Private Sub lblDragTop_DragOver(Source As Control, X As Single, Y As Single, State As Integer) If (Index = ScrollBottomItemIndex And ScrollBottomItemIndex = ItemMaxIndex) Or Index > ScrollBottomItemIndex Then Exit Sub End If If Not boolTimerScrollUp Then boolTimerScrollUp = True ScrollUp End If End Sub Private Sub lblDragBottom_DragOver(Source As Control, X As Single, Y As Single, State As Integer) If (Index = ScrollBottomItemIndex And ScrollBottomItemIndex = ItemMaxIndex) Or Index > ScrollBottomItemIndex Then Exit Sub End If If Not boolTimerScrollDown Then boolTimerScrollDown = True ScrollDown End If End Sub Private Sub Timer1_Timer() With frmSort If boolTimerScrollUp Then ScrollUp End If If boolTimerScrollDown Then ScrollDown End If End With End Sub Private Sub ScrollUp() With frmSort If ScrollTopItemIndex > ItemMinIndex Then ScrollTopItemIndex = ScrollTopItemIndex - 1 ScrollBottomItemIndex = ScrollBottomItemIndex - 1 .VScroll1.Value = .VScroll1.Value - 1 DrawList End If End With End Sub Private Sub ScrollDown() With frmSort If ScrollBottomItemIndex < ItemMaxIndex Then ScrollTopItemIndex = ScrollTopItemIndex + 1 ScrollBottomItemIndex = ScrollBottomItemIndex + 1 .VScroll1.Value = .VScroll1.Value + 1 DrawList End If End With End Sub Private Sub VScroll1_Change() Dim change As Integer With frmSort If Not inDragMode Then change = .VScroll1.Value - LastScrollValue If change + ScrollTopItemIndex < ItemMinIndex Then change = ItemMinIndex - LastScrollValue End If If change + ScrollBottomItemIndex > ItemMaxIndex Then change = change + ScrollBottomItemIndex - ItemMaxIndex End If ScrollTopItemIndex = ScrollTopItemIndex + change ScrollBottomItemIndex = ScrollBottomItemIndex + change If ScrollTopItemIndex < ItemMinIndex Then change = Abs(ItemMinIndex - ScrollTopItemIndex) ScrollTopItemIndex = ScrollTopItemIndex + change ScrollBottomItemIndex = ScrollBottomItemIndex + change End If If ScrollBottomItemIndex > ItemMaxIndex Then change = Abs(ItemMinIndex - ScrollTopItemIndex) ScrollTopItemIndex = ScrollTopItemIndex + change ScrollBottomItemIndex = ScrollBottomItemIndex + change End If DrawList End If LastScrollValue = .VScroll1.Value End With End Sub Sub RebuildCodeMap() Dim rs As ADODB.Recordset Dim LastSpace As Long Dim NextSpace As Long Dim VE As String Erase CodeMap CodeIndex = -1 ' ' Load Base values ' Set rs = dbConn.Execute("SELECT * FROM Release") AddCode 1100, "Release", rs("Release"), "Release Date" AddCode 1200, "Serial", FormatDateTime(rs("Serial"), vbShortDate), "Serial number" AddCode 1300, "Switches", rs("Switches") & " ", "Compiler switches" rs.Close Set rs = Nothing ' ' Load Objects ' Set rs = dbConn.Execute("SELECT * FROM Object Where SpaceNumber <> 0") LastSpace = 0 Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Object", rs("ObjectName"), "Object Definition" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Classes ' Set rs = dbConn.Execute("SELECT * FROM Class Where SpaceNumber <> 0") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Class", rs("ClassName"), "Class Definition" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Properties ' Set rs = dbConn.Execute("SELECT * FROM Property Where SpaceNumber <> 0") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Property", rs("PropertyName"), "Property Definition" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Attributes ' Set rs = dbConn.Execute("SELECT * FROM Attribute Where SpaceNumber <> 0") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Attribute", rs("AttributeName"), "Attribute Definition" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Globals ' Set rs = dbConn.Execute("SELECT * FROM Global") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Global", rs("GlobalName"), "Global Definition" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Constants ' Set rs = dbConn.Execute("SELECT * FROM Constant") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Constant", rs("ConstantName"), "Constant Definition" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Arrays ' Set rs = dbConn.Execute("SELECT * FROM Array") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Array", rs("ArrayName"), "Array Definition" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Includes ' Set rs = dbConn.Execute("SELECT * FROM Include") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Include", rs("FileName"), "Include Library or Module" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Comments ' Set rs = dbConn.Execute("SELECT * FROM Comment") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If AddCode NextSpace, "Comment", rs("Comment") & " ", "Comment Definition" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Load Grammar ' Set rs = dbConn.Execute("SELECT G.*,F.FunctionName FROM Grammar G, Function F Where G.FunctionId = F.FunctionId") Do Until rs.EOF NextSpace = rs("SpaceNumber") If LastSpace <> 0 Then If LastSpace = rs("SpaceNumber") Then NextSpace = LastSpace + 100 End If End If If rs("VerbExtend") = "V" Then VE = "Verb" Else VE = "Extend" End If AddCode NextSpace, VE, rs("Verbs"), rs("Phrase") & " " & Scope & " -> " & FunctionName & "();" LastSpace = NextSpace rs.MoveNext Loop rs.Close Set rs = Nothing ' ' Sort CodeMap ' SortCodeMap End Sub Sub SortCodeMap() Dim i As Integer, j As Integer, SaveMap As Items ' ' CodeMap(CodeIndex) needs sorting by CodeMap().Sort ' For i = 0 To CodeIndex - 1 For j = i To CodeIndex If CodeMap(j).Sort < CodeMap(i).Sort Then SaveMap = CodeMap(i) CodeMap(i) = CodeMap(j) CodeMap(j) = SaveMap End If Next j Next i End Sub Sub AddCode(lngSort As Long, strKind As String, strName As String, strDesc As String) CodeIndex = CodeIndex + 1 ReDim Preserve CodeMap(CodeIndex) CodeMap(CodeIndex).Sort = lngSort CodeMap(CodeIndex).Kind = strKind CodeMap(CodeIndex).Name = strName CodeMap(CodeIndex).Desc = strDesc End Sub