Dim fieldlist1$() AS string Dim orderList$() AS string Begin Dialog dlgMatchExample 0,10,249,129,"Matching Example", .displayIt Text 8,10,190,17, "File:", .txtPrimaryFileName PushButton 205,13,14,10, "...", .PushButton1 Text 7,44,190,17, "Second file", .txtSecondaryFilename PushButton 205,46,14,10, "...", .PushButton2 GroupBox 5,4,196,24, .GroupBox1 GroupBox 5,38,196,24, .GroupBox2 OKButton 14,76,40,14, "OK", .OKButton1 CancelButton 70,76,40,14, "Cancel", .CancelButton1 PushButton 145,76,40,14, "Match", .PushButton3 End Dialog Begin Dialog dlgMatch 0,20,396,201,"MatchKeyFields", .funcDlgMatch DropListBox 15,20,145,11, fieldlist1$(), .lstPrimMatch1 DropListBox 15,35,145,11, fieldlist1$(), .lstPrimMatch2 DropListBox 15,50,145,11, fieldlist1$(), .lstPrimMatch3 DropListBox 15,65,145,11, fieldlist1$(), .lstPrimMatch4 DropListBox 15,80,145,11, fieldlist1$(), .lstPrimMatch5 DropListBox 15,95,145,11, fieldlist1$(), .lstPrimMatch6 DropListBox 15,110,145,11, fieldlist1$(), .lstPrimMatch7 DropListBox 15,125,145,11, fieldlist1$(), .lstPrimMatch8 DropListBox 215,20,145,10, fieldlist1$(), .lstSecMatch1 DropListBox 215,35,145,10, fieldlist1$(), .lstSecMatch2 DropListBox 215,50,145,10, fieldlist1$(), .lstSecMatch3 DropListBox 215,65,145,10, fieldlist1$(), .lstSecMatch4 DropListBox 215,80,145,10, fieldlist1$(), .lstSecMatch5 DropListBox 215,95,145,10, fieldlist1$(), .lstSecMatch6 DropListBox 215,110,145,10, fieldlist1$(), .lstSecMatch7 DropListBox 215,125,145,10, fieldlist1$(), .lstSecMatch8 DropListBox 168,20,40,11, orderList$(), .lstOrderList1 DropListBox 168,35,40,11, orderList$(), .lstOrderList2 DropListBox 168,50,40,11, orderList$(), .lstOrderList3 DropListBox 168,65,40,11, orderList$(), .lstOrderList4 DropListBox 168,80,40,11, orderList$(), .lstOrderList5 DropListBox 168,95,40,11, orderList$(), .lstOrderList6 DropListBox 168,110,40,11, orderList$(), .lstOrderList7 DropListBox 168,125,40,11, orderList$(), .lstOrderList8 OKButton 39,151,40,14, "OK", .OKButton1 CancelButton 120,151,40,14, "Cancel", .CancelButton1 Text 57,5,60,10, "Primary", .Text1 Text 173,5,27,10, "Order", .Text2 Text 248,5,51,10, "Secondary", .Text3 End Dialog '************************************************************************************************************** '* Script: Matching Dialog Example.iss '* Author: Brian Element - brian.element@ideascripting.com '* Date: September 29, 2015 '* Purpose: Demo script to show how to create a dialog that emulates the IDEA matching dialog '* Results are returned to the sMatchList() mulit array where (i, 0) is the primary field '* (i, 1) is the secondary field and (i, 2) indicates if it is ascending or descending '************************************************************************************************************** Option Explicit Dim primaryFileName As String Dim secondaryFileName As String Dim working_directory As String Dim bExitScript As Boolean 'flag in case user hits cancel, the script will be exited Dim bOpenDialog As Boolean 'tracks if the help dialog is open so that it can only be open once Dim bMatchesSelected As Boolean 'flag to show if the matches have been selected Dim sMatchList(7, 2) As String 'used to hold the results of the match list Dim bMatchSelected(7, 2) As Boolean Dim sPrimaryFieldList() As String Dim sSecondaryFieldList() As String Dim Dlg2 As dlgMatch '**************************************************************************************************** ' Name: Main() ' Description: Main subroutine, call the menu and then displays the matches selected ' Accepts: Nothing ' Returns: Nothing '**************************************************************************************************** Sub Main Dim i As Integer Call mainMenu() For i = 0 To 7 MsgBox "Match " & (i + 1) & ": " & sMatchList(i, 0) & " - " & sMatchList(i, 2) & " - " & sMatchList(i, 1) Next i End Sub '**************************************************************************************************** ' Name: mainMenu() ' Description: Routine to call the main menu, if a file is open it sets that file to the primaryFileName variable ' Accepts: Nothing ' Returns: Nothing '**************************************************************************************************** Function mainMenu() Dim dlg As dlgMatchExample Dim button As Integer Dim db As database On Error Resume Next Set db = Client.CurrentDatabase() If err.number = 0 Then primaryFileName = db.name Else primaryFileName = "" End If Set db = Nothing button = Dialog(dlg) 'check to see if user hit dialog close (x) If button = 0 Then bExitScript = true End Function '**************************************************************************************************** ' Name: funcDlgMatch() ' Description: Routine to modify the dlgMatch dialog ' Accepts: Variables from the dlgMatch dialog ' Returns: Nothing '**************************************************************************************************** Function funcDlgMatch(ControlID$, Action%, SuppValue%) Dim bExitFun As Boolean Dim iMatchError As Integer 'indicates if the fields are of the same type -1 not both fields selected, 0 does not match, 1 matches Dim iMatchField As Integer Dim bRowUsed(7) As Boolean 'used to indicate if a row has already been added Dim bOneMatchSelected As Boolean 'used to make sure at least one match was selected Dim i, j As Integer Dim bPrimMatchError As Boolean 'used to indicate if a field has been used twice in the primary or secondary match Dim bSecMatchError As Boolean Dim sMatchError As String 'string to hold the match error message displayed to the user iMatchError = -1 'default to no error Select Case action Case 1 bMatchesSelected = false For i = 2 To 8 DlgEnable "lstPrimMatch" & i, 0 dlgEnable "lstOrderList" & i, 0 DlgEnable "lstSecMatch" & i, 0 Next i Call getFieldArray(primaryFileName, 1) Call sortArray(sPrimaryFieldList) Call getFieldArray(secondaryFileName, 2) Call sortArray(sSecondaryFieldList) DlgListBoxArray "lstPrimMatch1", sPrimaryFieldList() DlgListBoxArray "lstSecMatch1", sSecondaryFieldList() Case 2 Select Case ControlID$ Case "lstPrimMatch1" If SuppValue% > 0 Then bMatchSelected(0, 0) = true sMatchList(0,0) = sPrimaryFieldList(SuppValue%) iMatchField = 0 iMatchError = checkIfMatch(bMatchSelected(0, 0), bMatchSelected(0, 1), sMatchList(0,0), sMatchList(0,1)) End If Case "lstSecMatch1" If SuppValue% > 0 Then bMatchSelected(0, 1) = true sMatchList(0,1) = sSecondaryFieldList(SuppValue%) iMatchField = 0 iMatchError = checkIfMatch(bMatchSelected(0, 0), bMatchSelected(0, 1), sMatchList(0,0), sMatchList(0,1)) End If Case "lstPrimMatch2" If SuppValue% > 0 Then bMatchSelected(1, 0) = true sMatchList(1,0) = sPrimaryFieldList(SuppValue%) iMatchField = 1 iMatchError = checkIfMatch(bMatchSelected(1, 0), bMatchSelected(1, 1), sMatchList(1,0), sMatchList(1,1)) End If Case "lstSecMatch2" If SuppValue% > 0 Then bMatchSelected(1, 1) = true sMatchList(1, 1) = sSecondaryFieldList(SuppValue%) iMatchField = 1 iMatchError = checkIfMatch(bMatchSelected(1, 0), bMatchSelected(1, 1), sMatchList(1,0), sMatchList(1,1)) End If Case "lstPrimMatch3" If SuppValue% > 0 Then bMatchSelected(2, 0) = true sMatchList(2,0) = sPrimaryFieldList(SuppValue%) iMatchField = 2 iMatchError = checkIfMatch(bMatchSelected(2, 0), bMatchSelected(2, 1), sMatchList(2,0), sMatchList(2,1)) End If Case "lstSecMatch3" If SuppValue% > 0 Then bMatchSelected(2, 1) = true sMatchList(2,1) = sSecondaryFieldList(SuppValue%) iMatchField = 2 iMatchError = checkIfMatch(bMatchSelected(2, 0), bMatchSelected(2, 1), sMatchList(2,0), sMatchList(2,1)) End If Case "lstPrimMatch4" If SuppValue% > 0 Then bMatchSelected(3, 0) = true sMatchList(3,0) = sPrimaryFieldList(SuppValue%) iMatchField = 3 iMatchError = checkIfMatch(bMatchSelected(3, 0), bMatchSelected(3, 1), sMatchList(3,0), sMatchList(3,1)) End If Case "lstSecMatch4" If SuppValue% > 0 Then bMatchSelected(3, 1) = true sMatchList(3,1) = sSecondaryFieldList(SuppValue%) iMatchField = 3 iMatchError = checkIfMatch(bMatchSelected(3, 0), bMatchSelected(3, 1), sMatchList(3,0), sMatchList(3,1)) End If Case "lstPrimMatch5" If SuppValue% > 0 Then bMatchSelected(4, 0) = true sMatchList(4,0) = sPrimaryFieldList(SuppValue%) iMatchField = 4 iMatchError = checkIfMatch(bMatchSelected(4, 0), bMatchSelected(4, 1), sMatchList(4,0), sMatchList(4,1)) End If Case "lstSecMatch5" If SuppValue% > 0 Then bMatchSelected(4, 1) = true sMatchList(4,1) = sSecondaryFieldList(SuppValue%) iMatchField = 4 iMatchError = checkIfMatch(bMatchSelected(4, 0), bMatchSelected(4, 1), sMatchList(4,0), sMatchList(4,1)) End If Case "lstPrimMatch6" If SuppValue% > 0 Then bMatchSelected(5, 0) = true sMatchList(5,0) = sPrimaryFieldList(SuppValue%) iMatchField = 5 iMatchError = checkIfMatch(bMatchSelected(5, 0), bMatchSelected(5, 1), sMatchList(5,0), sMatchList(5,1)) End If Case "lstSecMatch6" If SuppValue% > 0 Then bMatchSelected(5, 1) = true sMatchList(5,1) = sSecondaryFieldList(SuppValue%) iMatchField = 5 iMatchError = checkIfMatch(bMatchSelected(5, 0), bMatchSelected(5, 1), sMatchList(5,0), sMatchList(5,1)) End If Case "lstPrimMatch7" If SuppValue% > 0 Then bMatchSelected(6, 0) = true sMatchList(6,0) = sPrimaryFieldList(SuppValue%) iMatchField = 6 iMatchError = checkIfMatch(bMatchSelected(6, 0), bMatchSelected(6, 1), sMatchList(6,0), sMatchList(6,1)) End If Case "lstSecMatch7" If SuppValue% > 0 Then bMatchSelected(6, 1) = true sMatchList(6,1) = sSecondaryFieldList(SuppValue%) iMatchField = 6 iMatchError = checkIfMatch(bMatchSelected(6, 0), bMatchSelected(6, 1), sMatchList(6,0), sMatchList(6,1)) End If Case "lstPrimMatch8" If SuppValue% > 0 Then bMatchSelected(7, 0) = true sMatchList(7,0) = sPrimaryFieldList(SuppValue%) iMatchField = 7 iMatchError = checkIfMatch(bMatchSelected(7, 0), bMatchSelected(7, 1), sMatchList(7,0), sMatchList(7,1)) End If Case "lstSecMatch8" If SuppValue% > 0 Then bMatchSelected(7, 1) = true sMatchList(7,1) = sSecondaryFieldList(SuppValue%) iMatchField = 7 iMatchError = checkIfMatch(bMatchSelected(7, 0), bMatchSelected(7, 1), sMatchList(7,0), sMatchList(7,1)) End If Case "OKButton1" 'check to make sure at least one match as been selected For i = 0 To 7 If sMatchList(i,0) <> "" And sMatchList(i,1) <> "" Then bOneMatchSelected = True End If Next i If Not bOneMatchSelected Then 'no matches, so give an error MsgBox "You must select at least one match" Else 'check to make sure the field is only used once for a match For i = 0 To 7 'check the primary match that there are no duplicates If sMatchList(i,0) <> "" Then For j = 0 To 7 If j <> i Then 'only do this match for different rows If sMatchList(i,0) = sMatchList(j,0) Then bPrimMatchError = true End If End If Next j End If Next i For i = 0 To 7 'check the secondary match that there are no duplicates If sMatchList(i,1) <> "" Then For j = 0 To 7 If j <> i Then 'only do this match for different rows If sMatchList(i,0) = sMatchList(j,1) Then bSecMatchError = true End If End If Next j End If Next i sMatchError = "" If bPrimMatchError Then sMatchError = "The same field has been selected twice in the primary match." & Chr(10) & Chr(13) End If If bSecMatchError Then sMatchError = sMatchError & "The same field has been selected twice in the secondary match." End If If sMatchError = "" Then 'if there is no error message then exit dialog, else show error 'get the information for ascending or descending sMatchList(0,2) = orderList$(dlgMatch.lstOrderList1) sMatchList(1,2) = orderList$(dlgMatch.lstOrderList2) sMatchList(2,2) = orderList$(dlgMatch.lstOrderList3) sMatchList(3,2) = orderList$(dlgMatch.lstOrderList4) sMatchList(4,2) = orderList$(dlgMatch.lstOrderList5) sMatchList(5,2) = orderList$(dlgMatch.lstOrderList6) sMatchList(6,2) = orderList$(dlgMatch.lstOrderList7) sMatchList(7,2) = orderList$(dlgMatch.lstOrderList8) bMatchesSelected = true 'remove the field type from the name For i = 0 To 7 If sMatchList(i, 0) <> "" Then sMatchList(i, 0) = Mid(sMatchList(i, 0), 1, Len(sMatchList(i, 0)) - 4) sMatchList(i, 1) = Mid(sMatchList(i, 1), 1, Len(sMatchList(i, 1)) - 4) End If Next i bExitFun = true Else MsgBox sMatchError, MB_ICONEXCLAMATION, "Problem" End If End If End Select End Select If iMatchError = 0 Then MsgBox "The fields must be of the same type", MB_ICONEXCLAMATION, "Problem" ElseIf iMatchError = 1 And bRowUsed(iMatchField) = False Then DlgEnable "lstPrimMatch" & iMatchField + 2, 1 DlgEnable "lstOrderList" & iMatchField + 2, 1 DlgEnable "lstSecMatch" & iMatchField + 2, 1 DlgListBoxArray "lstPrimMatch" & iMatchField + 2, sPrimaryFieldList() DlgListBoxArray "lstSecMatch"& iMatchField + 2, sSecondaryFieldList() bMatchSelected(i, 2) = true bRowUsed(iMatchField) = true End If If bExitFun Then funcDlgMatch = 0 Else funcDlgMatch = 1 End If 'Displays the information if needed 'DlgText "Text4", "Action: " & Action% & " ControlID$: " & ControlID$ & " SuppValue: " & SuppValue% End Function '**************************************************************************************************** ' Name: displayIt() ' Description: Routine to modify the dlgMatchExample dialog ' Accepts: Variables from the dlgMatchExample dialog ' Returns: Nothing '**************************************************************************************************** Function displayIt(ControlID$, Action%, SuppValue%) Dim bExitFun As Boolean Dim button As Integer Dim Dlg3 As dlgFields bExitFun = FALSE Select Case action Case 1 Case 2 Select Case ControlId$ Case "PushButton1" primaryFileName = getFile() Case "PushButton2" secondaryFileName = getFile() Case "PushButton3" If primaryFileName = secondaryFileName Then MsgBox "The primary file cannot be the same as the secondary file, please choose a different file", MB_ICONEXCLAMATION, "Problem" Else If Not bOpenDialog Then bOpenDialog = true Call disableButtons(True) ReDim orderList$(1) orderList$(0) = "Ascending" orderList$(1) = "Descending" button = Dialog(Dlg2) If button = 0 Or button = -1 Then bOpenDialog = false Call disableButtons(False) End If End If Case "CancelButton1" bExitFun = True bExitScript = True Case "OKButton1" If primaryFileName = "" Or secondaryFileName = "" Then MsgBox "Please select the files", MB_ICONEXCLAMATION, "Problem" ElseIf primaryFileName = secondaryFileName Then MsgBox "The primary and secondary files cannot be the same", MB_ICONEXCLAMATION, "Problem" ElseIf Not bMatchesSelected Then MsgBox "Please select the matches", MB_ICONEXCLAMATION, "Problem" Else bExitFun = True End If End Select End Select If primaryFileName = "" Then DlgText "txtPrimaryFileName", "Please select primary database." Else DlgText "txtPrimaryFileName", "Primary database: " & getFileName(primaryFileName, 0) End If If secondaryFileName = "" Then DlgText "txtSecondaryFilename", "Please select secondary database." Else DlgText "txtSecondaryFilename", "Secondary database: " & getFileName(secondaryFileName, 0) End If If secondaryFileName = "" Or primaryFileName = "" Then dlgEnable "PushButton3", 0 Else dlgEnable "PushButton3", 1 End If If bExitFun Then displayIt = 0 Else displayIt = 1 End If End Function '**************************************************************************************************** ' Name: disableButtons() ' Description: Routine to disable or reenable the buttons from the dlgMatchExample dialog ' Accepts: Boolean to indicate if disabling or reenabling ' Returns: Nothing '**************************************************************************************************** Function disableButtons(bDisable As Boolean) If bDisable Then DlgEnable "PushButton1", 0 DlgEnable "PushButton2", 0 DlgEnable "PushButton3", 0 DlgEnable "PushButton4", 0 DlgEnable "OKButton1", 0 DlgEnable "CancelButton1", 0 Else DlgEnable "PushButton1", 1 DlgEnable "PushButton2", 1 DlgEnable "PushButton3", 1 DlgEnable "PushButton4", 1 DlgEnable "OKButton1", 1 DlgEnable "CancelButton1", 1 End If End Function '**************************************************************************************************** ' Name: getFileName() ' Description: Routine to extract the filename from the path ' Accepts: The name of an IDEA file and a type that indicates if it should only return the filename or the filename with folder info ' Returns: The filename '**************************************************************************************************** Function getFileName(temp_filename As String, temp_type As Boolean) '1 if get the name with any folder info, 0 if only the name Dim temp_length As Integer Dim temp_len_wd As Integer Dim temp_difference As Integer Dim temp_char As String Dim tempfilename As String If temp_type Then temp_len_wd = Len(working_directory ) + 1'get the lenght of the working directory temp_length = Len(temp_filename) 'get the lenght of the file along with the working directory temp_difference = temp_length - temp_len_wd + 1'get the lenght of just the filename getFileName = Mid(temp_filename, temp_len_wd, temp_difference) Else temp_length = Len(temp_filename ) Do temp_char = Mid(temp_filename, temp_length , 1) temp_length = temp_length - 1 If temp_char <> "\" Then tempfilename = temp_char & tempfilename End If Loop Until temp_char = "\" Or temp_length = 0 getFileName = tempfilename End If End Function '**************************************************************************************************** ' Name: getFile() ' Description: Routine to display the IDEA fileexplorer and return the file name ' Accepts: nothing ' Returns: The filename '**************************************************************************************************** Function getFile() As String Dim filebar As Object Set filebar =CreateObject ("ideaex.FileExplorer") ' Display the File Explorer filebar.DisplayDialog ' Set Variable to store Select File Name getFile = filebar.SelectedFile End Function '**************************************************************************************************** ' Name: sortArray() ' Description: Routine to sort a 1 dimensional array ' Accepts: An array to be sorted ' Returns: The sorted array '**************************************************************************************************** Private Function sortArray(MyArray() As String) Dim lLoop, lLoop2 As Integer Dim str1, str2 As String For lLoop = 1 To UBound(MyArray) For lLoop2 = lLoop To UBound(MyArray) If UCase(MyArray(lLoop2)) < UCase(MyArray(lLoop)) Then str1 = MyArray(lLoop) str2 = MyArray(lLoop2) MyArray(lLoop) = str2 MyArray(lLoop2) = str1 End If Next lLoop2 Next lLoop End Function '**************************************************************************************************** ' Name: getFieldArrays() ' Description: Routine to return an array of the field names for the database and adding on the field type ' Accepts: The name IDEA database name and an indicator for which array to populate ' Returns: A global variable that holds field names and types '**************************************************************************************************** Function getFieldArray(sTempFilename As String, iArray As Integer) Dim db As database Dim table As table Dim field As field Dim i, j As Integer Dim count As Integer Dim iFieldType As Integer Dim sFieldArray() As String Dim sFieldName As String ReDim sFieldArray(1) j = 0 Set db = client.OpenDatabase(sTempFileName) Set table = db.TableDef count = table.count For i = 1 To count Set field = table.GetFieldAt(i) If Not field.IsVirtual Then iFieldType = field.Type sFieldName = field.Name Select Case iFieldType Case WI_NUM_FIELD sFieldName = sFieldName & " (N)" Case WI_CHAR_FIELD sFieldName = sFieldName & " (C)" Case WI_DATE_FIELD sFieldName = sFieldName & " (D)" Case WI_TIME_FIELD sFieldName = sFieldName & " (T)" End Select End If If j = 0 Then sFieldArray(0) = "Select one" sFieldArray(1) = sFieldName j = 1 Else ReDim preserve sFieldArray(UBound(sFieldArray) + 1) sFieldArray(UBound(sFieldArray)) = sFieldName End If Next i Set table = Nothing db.close Set db = Nothing If iArray = 1 Then ReDim sPrimaryFieldList(UBound(sFieldArray)) For i = 0 To UBound(sFieldArray) sPrimaryFieldList(i) = sFieldArray(i) Next i Else ReDim sSecondaryFieldList(UBound(sFieldArray)) For i = 0 To UBound(sFieldArray) sSecondaryFieldList(i) = sFieldArray(i) Next i End If End Function '**************************************************************************************************** ' Name: checkIfMatch() ' Description: Routine to validate that the user has selected the same fields types for the match ' Accepts: A flag to show that the primary and secondary field have been selected and the field choosen for each one ' Returns: 0 if the type is different 1 if it is the same '**************************************************************************************************** Function checkIfMatch(bPrimSel As Boolean, bSecSel As Boolean, sPrimMatch As String, sSecMatch As String) As Integer 'check to see both fields have been selected before continuing If Not bPrimSel Or Not bSecSel Then checkIfMatch = -1 'not complete Exit Function End If If Mid(sPrimMatch, Len(sPrimMatch) - 1, 1) <> Mid(sSecMatch, Len(sSecMatch) - 1, 1) Then checkIfMatch = 0 'type does not match Else checkIfMatch = 1 'type matches End If End Function