'TITLE: UPDATE DB2 OS390 INDEX STORAGE PARAMETERS.BAS 'DESCRIPTION: This macro provides a list of tables from the active ' physical model. The tables in the right box will be updated ' with the specified storage parameters. Tables can be added ' and removed from the updated list. 'AUTHOR: Jason Tiret 'CONTACT: http://support.embarcadero.com/ 'DATE: 7/7/2004 Option Explicit 'Global Array variables to handle available and selected tables. Dim AvailableIndexes() As String Dim SelectedIndexes() As String Dim AvailIndexesIndx As Integer Dim SelIndexesIndx As Integer Dim Stogroups() As String Dim BufferPool() As String 'Global ERStudio Variables Dim mdl As Model Dim diag As Diagram Dim ents As Entities Dim ent As Entity Dim indices As Indexes Dim indx As Index Dim indxcount As Integer Type IdxPair tblName As String idxname As String End Type Dim IndexPairs() As IdxPair Function getTableName ( idx As String ) As String Dim i As Integer Dim tblName As String For i = 0 To indxcount - 1 If IndexPairs(i).idxname = idx Then getTableName = IndexPairs(i).tblname Exit For End If Next 'getTableName = "" End Function 'This function is used to initialize the passed-in array with all 'the tables in the physical model. It will fill the target array 'when the AddAll and RemoveAll buttons in the dialog are pressed. Function SetupIndexArray(indxs As Variant) Debug.Print "SetupIndexArray" Dim i,count As Integer count = indxcount - 1 i = 0 If count < 0 Then ReDim indxs(0) As String Else ReDim indxs (0 To count) As String 'Refresh Array with table names For i = 0 To indxcount - 1 indxs(i) = IndexPairs(i).tblName & " -- " & IndexPairs(i).idxName Debug.Print vbTab & i & " = " & indxs(i) Next Debug.Print indxcount End If End Function 'This function clears the passed-in array of all the names. It clears the 'source array when the AddAll and RemoveAll buttons are pressed. Function ClearIndexArray(indxs As Variant) Dim i,count As Integer count = indxcount - 1 If count < 0 Then ReDim indxs(0) As String Else ReDim indxs (0 To count) As String For i = 0 To indxcount - 1 indxs(i) = "" i = i + 1 Next End If End Function Function SetupStogroups() Dim i, count As Integer Dim sto As DB2StoGroup count = mdl.DB2StoGroups.Count - 1 Debug.Print mdl.DB2StoGroups.Count i = 0 If count < 0 Then ReDim Stogroups(0) Else ReDim Stogroups(0 To count) For Each sto In mdl.DB2StoGroups Stogroups(i) = sto.Name i = i + 1 Next End If End Function 'This function is used to move single tables between the listboxes. It 'will add tables to the front of the target array and pad the back of the 'source array with blank entries Function MoveIndex (source As Variant, target As Variant, source_indx As Integer) Dim s_count As Integer 'upper bound of the source array Dim t_count As Integer 'upper bound of the target array Dim i As Integer s_count = UBound(source) t_count = UBound(target) - 1 Debug.Print "t_count = " & t_count 'move all the entries back one slot in the target array to make 'room for the new entry For i = t_count To 0 Step -1 target(i+1) = target(i) Debug.Print "target(" & i & ") = " & target(i) Next i 'add the new entry target(0) = source(source_indx) Debug.Print source(source_indx) & ", index = " & source_indx 'move all the entries after the vacant slot up one slot to fill the hole For i = source_indx + 1 To s_count source(i-1) = source(i) Next i 'pad the last entry with a null string source(s_count) = "" End Function Function setupBufferPool() ReDim BufferPool(0 To 80) BufferPool(0) = "(none)" BufferPool(1) = "BP0" BufferPool(2) = "BP1" BufferPool(3) = "BP2" BufferPool(4) = "BP3" BufferPool(5) = "BP4" BufferPool(6) = "BP5" BufferPool(7) = "BP6" BufferPool(8) = "BP7" BufferPool(9) = "BP8" BufferPool(10) = "BP9" BufferPool(11) = "BP10" BufferPool(12) = "BP11" BufferPool(13) = "BP12" BufferPool(14) = "BP13" BufferPool(15) = "BP14" BufferPool(16) = "BP15" BufferPool(17) = "BP16" BufferPool(18) = "BP17" BufferPool(19) = "BP18" BufferPool(20) = "BP19" BufferPool(21) = "BP20" BufferPool(22) = "BP21" BufferPool(23) = "BP22" BufferPool(24) = "BP23" BufferPool(25) = "BP24" BufferPool(26) = "BP25" BufferPool(27) = "BP26" BufferPool(28) = "BP27" BufferPool(29) = "BP28" BufferPool(30) = "BP29" BufferPool(31) = "BP30" BufferPool(32) = "BP31" BufferPool(33) = "BP32" BufferPool(34) = "BP33" BufferPool(35) = "BP34" BufferPool(36) = "BP35" BufferPool(37) = "BP36" BufferPool(38) = "BP37" BufferPool(39) = "BP38" BufferPool(40) = "BP39" BufferPool(41) = "BP40" BufferPool(42) = "BP41" BufferPool(43) = "BP42" BufferPool(44) = "BP43" BufferPool(45) = "BP44" BufferPool(46) = "BP45" BufferPool(47) = "BP46" BufferPool(48) = "BP47" BufferPool(49) = "BP48" BufferPool(50) = "BP49" BufferPool(51) = "BP8K0" BufferPool(52) = "BP8K1" BufferPool(53) = "BP8K2" BufferPool(54) = "BP8K3" BufferPool(55) = "BP8K4" BufferPool(56) = "BP8K5" BufferPool(57) = "BP8K6" BufferPool(58) = "BP8K7" BufferPool(59) = "BP8K8" BufferPool(60) = "BP8K9" BufferPool(61) = "BP16K0" BufferPool(62) = "BP16K1" BufferPool(63) = "BP16K2" BufferPool(64) = "BP16K3" BufferPool(65) = "BP16K4" BufferPool(66) = "BP16K5" BufferPool(67) = "BP16K6" BufferPool(68) = "BP16K7" BufferPool(69) = "BP16K8" BufferPool(70) = "BP16K9" BufferPool(71) = "BP32K" BufferPool(72) = "BP32K1" BufferPool(73) = "BP32K2" BufferPool(74) = "BP32K3" BufferPool(75) = "BP32K4" BufferPool(76) = "BP32K5" BufferPool(77) = "BP32K6" BufferPool(78) = "BP32K7" BufferPool(79) = "BP32K8" BufferPool(80) = "BP32K9" End Function Sub Main Debug.Clear 'set ERStudio variables Set diag = DiagramManager.ActiveDiagram Set mdl = diag.ActiveModel Set ents = mdl.Entities Dim count As Integer Dim i As Integer Dim tbl As String Dim idx As String Dim DBplatform As String If mdl.MajorPlatform <> "IBM DB2" Then MsgBox("Physical Model platform must be DB2 OS/390",,"Error!") Else Debug.Print "Initialize" For Each ent In mdl.Entities indxcount = indxcount + ent.Indexes.Count If ent.Indexes.Count <> 0 Then ReDim Preserve IndexPairs (0 To indxcount - 1) As IdxPair For Each indx In ent.Indexes IndexPairs(i).tblname = ent.TableName IndexPairs(i).idxname = indx.Name Debug.Print i & " = " & IndexPairs(i).idxname i = i + 1 Next End If Next Debug.Print indxcount 'initialize global arrays and indexes SetupIndexArray(AvailableIndexes) ClearIndexArray(SelectedIndexes) AvailIndexesIndx = 0 SelIndexesIndx = 0 SetupStogroups() setupBufferPool() 'Create the dialog Begin Dialog UserDialog 1150,483,"OS390 Index Storage Parameters",.DialogFunc ' %GRID:10,7,1,1 GroupBox 640,266,480,154,"Selected Indexes",.GroupBox2 ListBox 650,280,460,140,SelectedIndexes(),.SIndexes PushButton 550,273,60,21,">>",.AddAll GroupBox 30,266,490,154,"Available Indexes",.GroupBox1 ListBox 40,280,460,140,AvailableIndexes(),.AIndexes PushButton 550,301,60,21,">",.AddSelected PushButton 550,357,60,21,"<",.RemoveSelected PushButton 550,385,60,21,"<<",.RemoveAll OKButton 730,434,130,28 CancelButton 880,434,130,28 CheckBox 230,7,90,14,"Unique",.UniqueChbx CheckBox 230,28,90,14,"Cluster",.ClusterChbx CheckBox 600,7,180,14,"Do Not Close Dataset",.CloseChbx CheckBox 380,28,160,14,"Concurrent Copy",.CopyChbx GroupBox 200,49,600,175,"Storage Options",.GroupBox3 Text 230,70,90,14,"Using Clause",.Text1 OptionGroup .UsingClause OptionButton 250,91,90,14,"VCAT",.Vcat OptionButton 250,119,110,14,"STOGROUP",.StoGroup Text 260,147,60,14,"PRIQTY",.PriQty Text 260,168,70,14,"SECQTY",.SecQty CheckBox 230,196,100,14,"Erase Data",.erasedataChbx TextBox 370,84,150,21,.VCATtxt DropListBox 370,112,180,119,Stogroups(),.StoGrpName,1 TextBox 370,140,150,21,.PRIQTYtxt TextBox 370,168,150,21,.SECQTYtxt Text 570,70,90,14,"Buffer Pool",.Text4 Text 570,98,90,14,"Percent Free",.Text5 Text 570,126,90,14,"Free Page",.Text6 Text 570,154,90,14,"Piece Size",.Text7 DropListBox 680,63,100,140,BufferPool(),.BufferPool TextBox 680,91,100,21,.PercentFreetxt TextBox 680,119,100,21,.FreePagetxt TextBox 680,147,100,21,.PieceSizetxt Text 570,182,90,14,"GBP Cache",.Text8 OptionGroup .GBPCache OptionButton 680,175,90,14,"Changed",.Changed OptionButton 680,189,90,14,"All",.All OptionButton 680,203,90,14,"None",.None PushButton 90,238,90,21,"Sort List",.SortAvail PushButton 590,238,90,21,"Sort List",.SortSel CheckBox 380,7,140,14,"Where Not Null",.wherenotnullchbx CheckBox 600,28,180,14,"Defer Index Creation",.deferchbx End Dialog Dim dlg As UserDialog Dim Label As String Dim x As Integer Dim y As Integer Dim Length As Integer Dim ixname As String 'initialize dialog, -1 is the OK button, 0 is the CANCEL If Dialog(dlg,-2) = -1 Then 'Iterate through all the tables from the SelectedTables array For count = 0 To indxcount - 1 'don't want the null values in the SelectedTables array If SelectedIndexes(count) <> "" Then 'Get table name Label = SelectedIndexes(count) x = InStr(1, Label, " -- ") tbl = Left(Label, x - 1) Debug.Print "table= " & tbl 'get index name x = x + 5 Length = Len(Label) y = Length - x ixname = Right(Label, y) Debug.Print "index= " & ixname 'get the respective entity Set ent = mdl.Entities.Item(tbl) 'now get the respective index Set indx = ent.Indexes.Item(ixname) If dlg.usingclause = 1 Then If dlg.stogrpname <> "" Then indx.IsStoGroup = True indx.Location = dlg.stogrpname If dlg.priqtytxt <> "" Then indx.InitialExtentSize = CLng(dlg.priqtytxt) End If If dlg.secqtytxt <> "" Then indx.NextExtentSize = CLng(dlg.secqtytxt) End If If dlg.erasedatachbx = 1 Then indx.DB2Erase = True Else indx.DB2Erase = False End If End If Else If dlg.vcattxt <> "" Then indx.IsStoGroup = False indx.Location = dlg.vcattxt End If End If If dlg.UniqueChbx = 1 Then indx.Unique = True Else indx.Unique = False End If If dlg.clusterchbx = 1 Then indx.Clustered = True Else indx.Clustered = False End If If dlg.closechbx = 1 Then indx.DB2Close = False Else indx.DB2Close = True End If If dlg.copychbx = 1 Then indx.DB2Copy = True Else indx.DB2Copy = False End If If BufferPool(dlg.BufferPool) <> "(none)" Then indx.DB2BufferPool = BufferPool(dlg.BufferPool) End If If dlg.PercentFreetxt <> "" Then indx.PercentFree = CLng(dlg.PercentFreetxt) End If If dlg.FreePagetxt <> "" Then indx.PercentUsed = CLng(dlg.FreePagetxt) End If If dlg.PieceSizetxt <> "" Then indx.MaximumRowsPerPage = CLng(dlg.PieceSizetxt) End If If dlg.GBPCache = 0 Then indx.GBPCache = "CHANGED" ElseIf dlg.GBPCache = 1 Then indx.GBPCache = "ALL" Else indx.GBPCache = "NONE" End If If dlg.deferchbx = 1 Then indx.DB2Defer = True End If If dlg.wherenotnullchbx = 1 Then indx.DB2UniqueNotNull = True End If End If Next End If End If End Sub
Rem See DialogFunc help topic for more information. Private Function DialogFunc(DlgItem$, Action%, SuppValue&) As Boolean Select Case Action% Case 1 ' Dialog box initialization DlgEnable "vcattxt",False DlgValue "UsingClause", 1 DlgEnable "wherenotnullchbx", False Case 2 ' Value changing or button pressed If DlgItem = "AIndexes" Then 'update the AvailIndexesIndx with current index when a 'table is selected in the available tables listbox AvailIndexesIndx = SuppValue Debug.Print AvailIndexesIndx 'don't exit dialog DialogFunc = True ElseIf DlgItem = "SIndexes" Then 'update the SelIndexIndx with the current index when a 'table is selected in the selected tables listbox SelIndexesIndx = SuppValue Debug.Print SelIndexesIndx 'don't exit dialog DialogFunc = True ElseIf DlgItem = "AddAll" Then Debug.Print "addall" 'add all the tables to the SelectedIndexes array, remove all 'from the AvailableTables array SetupIndexArray(SelectedIndexes) ClearIndexArray(AvailableIndexes) 'refresh dialog listboxes DlgListBoxArray "SIndexes", SelectedIndexes() DlgListBoxArray "AIndexes", AvailableIndexes() 'don't exit dialog DialogFunc = True ElseIf DlgItem = "RemoveAll" Then Debug.Print "removeall" 'add all the tables to the AvailableTables array, remove all 'from the SelectedIndexes array SetupIndexArray(AvailableIndexes) ClearIndexArray(SelectedIndexes) 'refresh dialog listboxes DlgListBoxArray "AIndexes", AvailableIndexes() DlgListBoxArray "SIndexes", SelectedIndexes() 'don't exit dialog DialogFunc = True ElseIf DlgItem = "RemoveSelected" Then 'don't move the table if the value is null If SelectedIndexes(SelIndexesIndx) <> "" Then 'move the selected table from SelectedIndexes array to the 'AvailableIndexes array MoveIndex(SelectedIndexes, AvailableIndexes, SelIndexesIndx) 'refresh dialog listboxes DlgListBoxArray "AIndexes", AvailableIndexes() DlgListBoxArray "SIndexes", SelectedIndexes() 're-initalize array indexes SelIndexesIndx = 0 AvailIndexesIndx = 0 End If 'don't exit dialog DialogFunc = True ElseIf DlgItem = "AddSelected" Then 'Don't move table if there isn't any value in the list box If AvailableIndexes(AvailIndexesIndx) <> "" Then 'move the selected table from the AvailableIndexes array to 'the SelectedIndexes array MoveIndex(AvailableIndexes, SelectedIndexes, AvailIndexesIndx) 'refresh dialog listboxes DlgListBoxArray "AIndexes", AvailableIndexes() DlgListBoxArray "SIndexes", SelectedIndexes() 're-initalize array indexes SelIndexesIndx = 0 AvailIndexesIndx = 0 End If 'don't exit dialog DialogFunc = True ElseIf DlgItem = "SortAvail" Then dhQuickSort AvailableIndexes() adjustArray(AvailableIndexes()) DlgListBoxArray "AIndexes", AvailableIndexes() DialogFunc = True ElseIf DlgItem = "SortSel" Then dhQuickSort SelectedIndexes() adjustArray(SelectedIndexes()) DlgListBoxArray "SIndexes", SelectedIndexes() DialogFunc = True ElseIf DlgItem = "UsingClause" Then If DlgValue("UsingClause") = 0 Then DlgEnable "VCATtxt",True DlgEnable "stogrpname",False DlgEnable "PriQtytxt",False DlgEnable "SecQtytxt",False DlgEnable "erasedatachbx",False Else DlgEnable "vcattxt",False DlgEnable "stogrpname",True DlgEnable "PriQtytxt",True DlgEnable "SecQtytxt",True DlgEnable "erasedatachbx",True End If ElseIf DlgItem = "UniqueChbx" Then If DlgValue ("UniqueChbx") = 1 Then DlgEnable "wherenotnullchbx", True Else DlgEnable "wherenotnullchbx", False End If End If Rem DialogFunc = True ' Prevent button press from closing the dialog box Case 3 ' TextBox or ComboBox text changed Case 4 ' Focus changed Case 5 ' Idle Rem DialogFunc = True ' Continue getting idle actions Case 6 ' Function key End Select End Function Function adjustArray(varArray As Variant) Dim i, intItems As Integer intItems = UBound(varArray) While varArray(0) = "" For i = 1 To intItems varArray(i - 1) = varArray(i) Next varArray(intItems) = "" Wend End Function ' From "VBA Developer's Handbook" ' by Ken Getz and Mike Gilbert ' Copyright 1997; Sybex, Inc. All rights reserved. ' Quicksort for simple data types. ' Indicate that a parameter is missing. Const dhcMissing = -2 Sub dhQuickSort(varArray As Variant, _ Optional intLeft As Integer As Integer ' From "VBA Developer's Handbook" ' by Ken Getz and Mike Gilbert ' Copyright 1997; Sybex, Inc. All rights reserved. ' Entry point for sorting the array. ' This technique uses the recursive Quicksort ' algorithm to perform its sort. ' In: ' varArray: ' A variant pointing to an array to be sorted. ' This had better actually be an array, or the ' code will fail, miserably. You could add ' a test for this: ' If Not IsArray(varArray) Then Exit Sub ' but hey, that would slow this down, and it's ' only YOU calling this procedure. ' Make sure it's an array. It's your problem. ' intLeft: ' intRight: ' Lower and upper bounds of the array to be sorted. ' If you don't supply these values (and normally, you won't) ' the code uses the LBound and UBound functions ' to get the information. In recursive calls ' to the sort, the caller will pass this information in. ' To allow for passing integers around (instead of ' larger, slower variants), the code uses -2 to indicate ' that you've not passed a value. This means that you won't ' be able to use this mechanism to sort arrays with negative ' indexes, unless you modify this code. ' Out: ' The data in varArray will be sorted. Dim i As Integer Dim j As Integer Dim varTestVal As Variant Dim intMid As Integer If intLeft = dhcMissing Then intLeft = LBound(varArray) If intRight = dhcMissing Then intRight = UBound(varArray) If intLeft < intRight Then intMid = (intLeft + intRight) \ 2 varTestVal = UCase(varArray(intMid)) i = intLeft j = intRight Do Do While UCase(varArray(i)) < varTestVal i = i + 1 Loop Do While UCase(varArray(j)) > varTestVal j = j - 1 Loop If i <= j Then SwapElements varArray, i, j i = i + 1 j = j - 1 End If Loop Until i > j ' To optimize the sort, always sort the ' smallest segment first. If j <= intMid Then Call dhQuickSort(varArray, intLeft, j) Call dhQuickSort(varArray, i, intRight) Else Call dhQuickSort(varArray, i, intRight) Call dhQuickSort(varArray, intLeft, j) End If End If End Sub
Private Sub SwapElements(varItems As Variant, intItem1 As Integer, intItem2 As Integer) Dim varTemp As Variant varTemp = varItems(intItem2) varItems(intItem2) = varItems(intItem1) varItems(intItem1) = varTemp End Sub