'TITLE: UPDATE DB2 OS390 TABLE 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: 10/17/2001 'LAST UPDATE: 7/3/2003 'Global Array variables to handle available and selected tables. Dim AvailableTables() As String Dim SelectedTables() As String Dim AvailTablesIndx As Integer Dim SelTablesIndx As Integer Dim Databases() As String Dim Tablespaces() As String 'Global ERStudio Variables Dim mdl As Model Dim diag As Diagram Dim ents As Entities Dim ent As Entity Dim entcount As Integer '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 SetupTableArray(Tables As Variant) Debug.Print "SetupTableArray" Dim i As Integer entcount = ents.Count - 1 i = 0 If entcount < 0 Then ReDim Tables(0) Else 're-initialize the array ReDim Tables(0 To entcount) As String 'Refresh Array with table names For Each ent In mdl.Entities Tables(i) = ent.TableName i = i + 1 Next 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 ClearTableArray(Tables As Variant) Debug.Print "ClearTableArray" entcount = ents.Count - 1 If entcount < 0 Then ReDim Tables(0) Else 'Clear the Array ReDim Tables(0 To entcount) As String For Each ent In mdl.Entities Tables(i) = "" 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 MoveTable (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 setupTablespaces() Dim i, count As Integer Dim tblspc As DB2Tablespace i = 0 count = mdl.DB2Tablespaces.Count - 1 If count < 0 Then ReDim Tablespaces(0) Else ReDim Tablespaces(0 To count) For Each tblspc In mdl.DB2Tablespaces Tablespaces(i) = tblspc.Name i = i + 1 Next End If End Function Function setupDatabases() Dim i, count As Integer Dim db As DB2Database i = 0 count = mdl.DB2Databases.Count - 1 If count < 0 Then ReDim database(0) Else ReDim Databases(0 To count) For Each db In mdl.DB2Databases Databases(i) = db.Name i = i + 1 Next End If 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 If mdl.MajorPlatform <> "IBM DB2" Then MsgBox("Physical Model platform must be DB2 OS/390",,"Error!") Else 'initialize global arrays and indexes SetupTableArray(AvailableTables) ClearTableArray(SelectedTables) AvailTablesIndx = 0 SelTablesIndx = 0 setupTablespaces() setupDatabases() 'Create the dialog Begin Dialog UserDialog 730,553,"DB2 Storage Parameters",.DialogFunc ' %GRID:10,7,1,1 GroupBox 410,287,300,203,"Selected Tables",.GroupBox2 ListBox 420,301,280,189,SelectedTables(),.STables GroupBox 20,14,320,98,"Location",.GroupBox3 Text 40,63,80,14,"Tablespace:",.Text1 PushButton 330,315,60,21,">>",.AddAll GroupBox 20,287,290,203,"Available Tables",.GroupBox1 ListBox 30,301,270,189,AvailableTables(),.ATables PushButton 330,350,60,21,">",.AddSelected PushButton 330,420,60,21,"<",.RemoveSelected PushButton 330,455,60,21,"<<",.RemoveAll OKButton 360,504,130,28 CancelButton 520,504,130,28 Text 40,35,80,14,"Database:",.Text2 DropListBox 140,28,180,112,Databases(),.Database,1 DropListBox 140,56,180,175,Tablespaces(),.TableSpace,1 CheckBox 60,126,90,14,"Encoding",.EncodingChbx CheckBox 200,126,130,14,"Restrict On Drop",.restrictChbx OptionGroup .EncodingOpt OptionButton 100,147,90,14,"ASCII",.OptionButton1 OptionButton 100,168,90,14,"EBCDIC",.OptionButton2 GroupBox 30,189,310,49,"Logging",.GroupBox4 CheckBox 60,210,170,14,"Log Data Changes",.LogDataChbx GroupBox 370,14,330,98,"Table Procedures",.GroupBox5 Text 400,42,90,14,"Edit Proc:",.Text3 Text 400,70,90,14,"Valid Proc:",.Text4 TextBox 490,42,170,21,.Editproc TextBox 490,70,170,21,.ValidProc GroupBox 370,133,330,105,"Audit Option",.GroupBox6 OptionGroup .AuditOpt OptionButton 450,154,90,14,"None",.OptionButton3 OptionButton 450,182,90,14,"Changes",.OptionButton4 OptionButton 450,210,90,14,"All",.OptionButton5 PushButton 40,252,120,21,"Sort List",.SortAvail PushButton 430,252,110,21,"Sort List",.SortSel End Dialog Dim dlg As UserDialog 'initialize dialog, -1 is the OK button, 0 is the CANCEL If Dialog(dlg,-2) = -1 Then 'reinitialize entity count entcount = ents.Count - 1 'Iterate through all the tables from the SelectedTables array For count = 0 To entcount 'don't want the null values in the SelectedTables array If SelectedTables(count) <> "" Then Set ent = ents.Item(SelectedTables(count)) 'Update the tablespace and database location with the give tablespace name If dlg.Database <> "" Then ent.DatabaseLocation = dlg.Database End If If dlg.TableSpace <> "" Then ent.StorageLocation = dlg.TableSpace End If 'Update the Edit proc If dlg.editproc <> "" Then ent.DB2EditProc = dlg.editproc End If 'Update the Valid proc If dlg.validproc <> "" Then ent.DB2ValidProc = dlg.validproc End If 'Update the restrict option If dlg.restrictchbx = 1 Then ent.DB2RestrictOnDrop = True Else ent.DB2RestrictOnDrop = False End If 'Update encoding option If dlg.encodingchbx = 1 Then 'determine which type of encoding If dlg.encodingopt = 0 Then ent.DB2Encoding = "ASCII" Else ent.DB2Encoding = "EBCDIC" End If Else ent.DB2Encoding = "NONE" End If 'Update audit option If dlg.auditopt = 0 Then ent.DB2Auditing = "NONE" ElseIf dlg.auditopt = 1 Then ent.DB2Auditing = "CHANGES" Else ent.DB2Auditing = "ALL" End If 'Update logging option If dlg.logdatachbx = 1 Then ent.DB2DataCaptureChg = True Else ent.DB2DataCaptureChg = False 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 = "ATables" Then 'update the AvailTablesIndx with current index when a 'table is selected in the available tables listbox AvailTablesIndx = SuppValue Debug.Print AvailTablesIndx 'don't exit dialog DialogFunc = True ElseIf DlgItem = "STables" Then 'update the SelTablesIndx with the current index when a 'table is selected in the selected tables listbox SelTablesIndx = SuppValue Debug.Print SelTablesIndx 'don't exit dialog DialogFunc = True ElseIf DlgItem = "AddAll" Then Debug.Print "addall" 'add all the tables to the SelectedTables array, remove all 'from the AvailableTables array SetupTableArray(SelectedTables) ClearTableArray(AvailableTables) 'refresh dialog listboxes DlgListBoxArray "STables", SelectedTables() DlgListBoxArray "ATables", AvailableTables() '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 SelectedTables array SetupTableArray(AvailableTables) ClearTableArray(SelectedTables) 'refresh dialog listboxes DlgListBoxArray "ATables", AvailableTables() DlgListBoxArray "STables", SelectedTables() 'don't exit dialog DialogFunc = True ElseIf DlgItem = "RemoveSelected" Then 'don't move the table if the value is null If SelectedTables(SelTablesIndx) <> "" Then 'move the selected table from SelectedTables array to the 'AvailableTables array MoveTable(SelectedTables, AvailableTables, SelTablesIndx) 'refresh dialog listboxes DlgListBoxArray "ATables", AvailableTables() DlgListBoxArray "STables", SelectedTables() 're-initalize array indexes SelTablesIndx = 0 AvailTablesIndx = 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 AvailableTables(AvailTablesIndx) <> "" Then 'move the selected table from the AvailableTables array to 'the SelectedTables array MoveTable(AvailableTables, SelectedTables, AvailTablesIndx) 'refresh dialog listboxes DlgListBoxArray "ATables", AvailableTables() DlgListBoxArray "STables", SelectedTables() 're-initalize array indexes SelTablesIndx = 0 AvailTablesIndx = 0 End If 'don't exit dialog DialogFunc = True ElseIf DlgItem = "SortAvail" Then dhQuickSort AvailableTables() adjustArray(AvailableTables()) DlgListBoxArray "ATables", AvailableTables() DialogFunc = True ElseIf DlgItem = "SortSel" Then dhQuickSort SelectedTables() adjustArray(selectedtables()) DlgListBoxArray "STables", SelectedTables() DialogFunc = True 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