'TITLE: SELECTIVELY UPDATE ORACLE INDEX STORAGE.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: 3/13/2002 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 'array variables Dim tblspaces() As String Dim MaxExts() As String Dim BufferPool() As String 'Global ERStudio Variables Dim mdl As Model Dim diag As Diagram Dim submdl As SubModel Dim ent As Entity Dim so As SelectedObject 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 Sub setBP ReDim BufferPool (0 To 4) As String BufferPool(0) = "NONE" BufferPool(1) = "DEFAULT" BufferPool(2) = "KEEP" BufferPool(3) = "RECYCLE" End Sub Sub setMaxExts ReDim MaxExts(0 To 1) As String MaxExts(1) = "UNLIMITED" End Sub Sub gettblspaces Dim i, count As Integer Dim oratblspc As OracleTablespace count = mdl.OracleTablespaces.Count i = 0 If count = 0 Then ReDim tblspaces(0) Else ReDim tblspaces (0 To count - 1) For Each oratblspc In mdl.OracleTablespaces tblspaces(i) = oratblspc.Name i = i + 1 Next End If End Sub 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 '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 Sub Main Debug.Clear 'set ERStudio variables Set diag = DiagramManager.ActiveDiagram Set mdl = diag.ActiveModel Set submdl = mdl.ActiveSubModel Dim count As Integer Dim i As Integer Dim tbl As String Dim idx As String Dim DBplatform As String DBplatform = Left(mdl.DatabasePlatform,6) Debug.Print DBplatform Debug.Print mdl.MajorPlatform Debug.Print mdl.DatabasePlatform If DBplatform <> "Oracle" Then MsgBox("Physical Model platform must be Oracle",,"Error!") Else Debug.Print "Initialize" For Each so In submdl.SelectedObjects If so.Type = 1 Then Set ent = mdl.Entities.Item(so.ID) 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 End If Next Debug.Print indxcount 'initialize global arrays and indexes SetupIndexArray(AvailableIndexes) ClearIndexArray(SelectedIndexes) AvailIndexesIndx = 0 SelIndexesIndx = 0 gettblspaces setBP setMaxExts 'Create the dialog Begin Dialog UserDialog 1170,525,"Oracle Index Storage Parameters",.DialogFunc ' %GRID:10,7,1,1 GroupBox 650,308,480,154,"Selected Indexes",.GroupBox2 ListBox 660,322,460,140,SelectedIndexes(),.SIndexes PushButton 560,329,60,21,">>",.AddAll GroupBox 40,308,490,154,"Available Indexes",.GroupBox1 ListBox 50,322,460,140,AvailableIndexes(),.AIndexes PushButton 560,357,60,21,">",.AddSelected PushButton 560,406,60,21,"<",.RemoveSelected PushButton 560,434,60,21,"<<",.RemoveAll OKButton 770,483,130,28 CancelButton 910,483,130,28 GroupBox 120,14,280,140,"Properties",.GroupBox6 GroupBox 430,14,210,140,"Physical",.GroupBox8 GroupBox 20,161,380,105,"Segment",.GroupBox3 DropListBox 80,203,280,91,tblspaces(),.tblspcsdd,1 GroupBox 430,161,210,105,"Group",.GroupBox4 PushButton 80,280,90,21,"Sort List",.SortAvail GroupBox 660,14,350,252,"Storage",.GroupBox5 DropListBox 810,238,120,70,BufferPool(),.bufferpooldd CheckBox 440,161,70,14,"Parallel",.Parallelchbx PushButton 640,280,90,21,"Sort List",.SortSel Text 440,42,70,14,"Pct Free:",.PctFree Text 440,77,90,14,"Initial Trans:",.initrans Text 440,112,90,14,"Max Trans:",.maxtrans TextBox 530,35,90,21,.pctfreetxt TextBox 530,70,90,21,.initranstxt TextBox 530,105,90,21,.maxtranstxt Text 40,182,90,14,"Tablespace:",.tblspc Text 440,189,70,14,"Degrees:",.degrees Text 440,224,90,14,"Instances:",.Text7 TextBox 530,182,90,21,.degreestxt TextBox 530,217,90,21,.instancestxt CheckBox 90,238,110,14,"No Logging",.nologgingchbx Text 690,42,90,14,"Initial Extent:",.Text8 Text 690,70,90,14,"Next Extent:",.Text9 Text 690,98,90,14,"Pct Increase:",.Text10 Text 690,126,90,14,"Min Extents:",.Text11 TextBox 800,35,130,21,.iniextenttxt TextBox 800,63,130,21,.NextExtenttxt Text 690,182,90,14,"Free Lists:",.Text13 TextBox 800,91,130,21,.pctincreasetxt TextBox 800,119,130,21,.minextentstxt DropListBox 800,147,130,49,MaxExts(),.maxextentsdd,1 TextBox 800,175,130,21,.freeliststxt Text 670,210,120,14,"Free List Groups:",.Text14 TextBox 800,203,130,21,.freelistgroupstxt Text 680,238,90,14,"Buffer Pool:",.Text15 Text 680,154,90,14,"Max Extents:",.Text12 Text 950,42,20,14,"KB",.Text1 Text 950,70,20,14,"KB",.Text2 Text 140,35,80,14,"Index Type:",.Text3 OptionGroup .indxtypeopt OptionButton 250,42,90,14,"B-Tree",.btree OptionButton 250,63,90,14,"Bitmap",.bitmap CheckBox 150,84,90,14,"Unique",.uniquechbx CheckBox 150,105,90,14,"No Sort",.nosortchbx CheckBox 150,126,160,14,"Reverse Byte Order",.reversechbx Text 50,483,360,28,"NOTE: Setting fields to -1 will set storage parameters in the table editors to NULL",.Text4 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) 'update index parameters If dlg.indxtypeopt = 0 Then indx.OracleBitMap = False If dlg.uniquechbx = 1 Then indx.Unique = True End If If dlg.reversechbx = 1 Then indx.OracleReverseByteOrder = True End If If dlg.nosortchbx = 1 Then indx.OracleNoSort = True End If Else indx.OracleBitMap = True indx.Unique = False indx.OracleNoSort = False indx.OracleReverseByteOrder = False End If If IsNumeric(dlg.nextextenttxt) Then indx.NextExtentSize = CLng(dlg.nextextenttxt) End If If IsNumeric(dlg.freelistgroupstxt) Then indx.FreeListGroups = CLng(dlg.freelistgroupstxt) End If If IsNumeric(dlg.FreeListstxt) Then indx.FreeLists = CLng(dlg.FreeListstxt) End If If IsNumeric(dlg.iniextenttxt) Then indx.InitialExtentSize = CLng(dlg.iniextenttxt) End If indx.Location = dlg.tblspcsdd Debug.Print dlg.maxextentsdd If dlg.maxextentsdd = "UNLIMITED" Then indx.MaximumExtents = 2147483645 Else If IsNumeric (dlg.maxextentsdd) Then indx.MaximumExtents = CLng(dlg.maxextentsdd) 'This line works if uncommented, but can't set parameter to "UNLIMITED" End If End If Debug.Print DiagramManager.GetLastErrorString If IsNumeric(dlg.maxtranstxt) Then indx.MaximumTransactions = CLng(dlg.maxtranstxt) End If If IsNumeric(dlg.minextentstxt) Then indx.MinimumExtents = CLng(dlg.minextentstxt) End If If IsNumeric(dlg.initranstxt) Then indx.MinimumTransactions = CLng(dlg.initranstxt) End If If IsNumeric(dlg.pctincreasetxt) Then indx.ExtentGrowthFactor = CLng(dlg.pctincreasetxt) End If If dlg.nologgingchbx = 1 Then indx.NoLogging = True End If indx.OracleBufferPool = BufferPool(dlg.bufferpooldd) If dlg.parallelchbx = 1 Then indx.OracleParallel = True If IsNumeric(dlg.degreestxt) Then indx.OracleDegrees = CLng(dlg.degreestxt) End If If IsNumeric(dlg.instancestxt) Then indx.OracleInstances = CLng(dlg.instancestxt) End If End If If IsNumeric(dlg.pctfreetxt) Then indx.PercentFree = CLng(dlg.pctfreetxt) 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 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 = "OK" Then If DlgValue("nosortchbx") = 1 And DlgValue("reversechbx") Then MsgBox("The No Sort and Reverse Byte Order can not be both set.",,"ERROR!") DialogFunc = True 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