Dim listbox1$() AS string
Dim listbox2$() AS STRING

Begin Dialog dlgSelectfields 0,0,400,270,"Select Files for Appending", .funSelectFiles
  ListBox 17,29,150,146, listbox1$(), .ListBox1
  ListBox 214,30,150,146, listbox2$(), .ListBox2
  PushButton 178,48,20,14, ">", .PushButton1
  PushButton 178,73,20,14, "<", .PushButton2
  PushButton 178,108,20,14, ">>", .PushButton3
  PushButton 178,133,20,14, "<<", .PushButton4
  OKButton 28,215,40,14, "OK", .OKButton1
  CancelButton 91,215,40,14, "Cancel", .CancelButton1
  Text 174,6,40,18, "Select Files", .txtTitle
  Text 155,208,214,29, "This script will append the select files but it will first change all numeric, date and time fields to character fields before the append.  It does not change virtual or editable fields.", .Text1
  Text 30,183,58,22, "Append filename (do not include the extension)", .Text2
  TextBox 95,182,165,14, .TextBox1
End Dialog
'********************************************************************************************************************************************
'* Script:	Append - change to char fields.iss
'* Author:	Brian Element - brian.element@ideascripting.com
'* Date:	June 21, 2015
'* Purpose:	This script will append numerious files together.  It will first change all fields (except for virtual and editable) to character before doing the append. 
'* This script is presented without any warranty or guarantee.  Users are encouraged to validate the effectiveness and reliability on their own.
'********************************************************************************************************************************************

Option Explicit

Dim sFolder As String
Dim working_directory  As String
Dim bExitScript As Boolean 'flag in case user hits cancel, the script will be exited
Dim sFiles() As String
Dim newFilename As String

Dim tempListbox1() As String 'needed for the variables for the dlgSeletFiles
Dim tempListBox2() As String 'needed for the variables for the dlgSeletFiles
Dim tempListSelect1 As Integer ' var to hold the last SuppValue before hitting the button - need as a global so it is remembered
Dim tempListSelect2 As Integer ' var to hold the last SuppValue before hitting the button - need as a global so it is remembered


Sub Main
	working_directory = Client.WorkingDirectory()
	Call menu()
	If Not bExitScript Then
		Call updateFields()
		Call appendFiles()
	End If
	client.RefreshFileExplorer
	MsgBox "Script Complete"
End Sub

Function appendFiles()
	Dim db As database
	Dim task As task
	Dim dbName As String
	Dim i As Integer
	
	Set db = Client.OpenDatabase(sFolder & sFiles(0))
	Set task = db.AppendDatabase
	For i = 1 To UBound(sFiles)
		task.AddDatabase sFolder & sFiles(i)
	Next i
	dbName = client.UniqueFilename(newFilename)
	task.PerformTask dbName, ""
	Set task = Nothing
	Set db = Nothing
	Client.OpenDatabase (dbName)

End Function

Function updateFields()
	Dim i, j As Integer
	Dim db As database
	Dim table As table
	Dim task As task
	Dim field As field
	Dim updateField As Object
	Dim iFieldCount As Integer
	Dim sFieldName As String
	
	For i = 0 To UBound(sFiles)
		Set db = client.OpenDatabase(sFolder & sFiles(i))
			Set task = db.TableManagement
			Set table = db.TableDef
				iFieldCount = table.count
				For j = 1 To iFieldCount
					Set field = table.GetFieldAt(j)
						sFieldName = field.Name
						If field.IsNumeric Then
							Set updateField = db.TableDef.NewField
								updateField.Name = sFieldName
								updateField.Description = ""
								updateField.Type = WI_CHAR_FIELD
								updateField.Equation = ""
								updateField.Length =20
								task.ReplaceField sFieldName, updateField
								task.PerformTask
							Set updateField = Nothing

						ElseIf field.IsDate Then
							Set updateField = db.TableDef.NewField
								updateField.Name = sFieldName
								updateField.Description = ""
								updateField.Type = WI_CHAR_FIELD
								updateField.Equation = ""
								updateField.Length = 20
								task.ReplaceField sFieldName, updateField
								task.PerformTask
							Set updateField = Nothing

						ElseIf field.IsTime Then
							Set updateField = db.TableDef.NewField
								updateField.Name = sFieldName
								updateField.Description = ""
								updateField.Type = WI_CHAR_FIELD
								updateField.Equation = ""
								updateField.Length = 20
								task.ReplaceField sFieldName, updateField
								task.PerformTask
							Set updateField= Nothing

						End If
					Set field = Nothing
				Next j
			Set table = Nothing
			Set task = Nothing
		Set db = Nothing
	Next i
End Function

Function menu()
	Dim dlg As dlgSelectFields
	Dim button As Integer
	Dim i As Integer

	sFolder = getFolder()
	If sFolder = "" Then
		MsgBox "Script aborted"
		bExitScript = True
		Exit Function
	End If
	Call getFiles()
	If Not bExitScript Then
		Call sortArray(sFiles)
		button = Dialog(dlg)
	End If

End Function

Function funSelectFiles(ControlID$, Action%, SuppValue%)
	Dim bExitMenu As Boolean 'flag to indicate if the dialog should close or remain open
	Dim i As Integer
	Dim j As Integer
	Dim k, l As Integer 'used to update tempListbox1 and 2 array
	Dim bListBox2Set As Boolean 'flag to show item was in placed in listbox2
	Select Case action
		Case 1
			'initialize the variables
			ReDim tempListbox1(0) 
			ReDim tempListbox2(0)
			
			l = 0
			k = 0
			'takes the items from the fields array and places them in the tempListBox1 array and then place the contents in lisbox1
			For i = 0 To UBound(sFiles)
				ReDim Preserve tempListbox1(UBound(tempListbox1) + 1)
				If sFiles(i) <> "" Then
					tempListbox1(i) = sFiles(i)
				End If
			Next i
			Call sortArray(tempListbox1)
			Call removeBlanksFromArray(1)
			DlgListBoxArray "ListBox1", tempListbox1
			tempListSelect1 = 0  'set to 1st items as default
		Case 2
			Select Case ControlId$
				'this will take the item selected from listbox1 and add it to listbox2
				Case "PushButton1"
					ReDim Preserve tempListbox2(UBound(tempListbox2) + 1)
					
					tempListbox2(UBound(tempListbox2)) = tempListbox1(tempListSelect1)

					tempListbox1(tempListSelect1 ) = ""
					
					'sort and remove any blancks from the array
					Call sortArray(tempListbox1)
					Call sortArray(tempListbox2)
					Call removeBlanksFromArray(1)
					Call removeBlanksFromArray(2)
					
					'add the contents of tempListbox1 and 2 to the Listboxes
					DlgListBoxArray "ListBox2", tempListbox2()
					DlgListBoxArray "ListBox1", tempListbox1()
					
					tempListSelect1 = 0 'set to 1st items as default
					bExitMenu = FALSE 'don't close the dialog
				'this will take an item selected from lisbox2 and add it to listbox1
				Case "PushButton2"

					ReDim Preserve tempListbox1(UBound(tempListbox1) + 1)
					
					tempListbox1(UBound(tempListbox1)) = tempListbox2(tempListSelect2)

					tempListbox2(tempListSelect2 ) = ""
					
					'sort and remove any blanks from teh array
					Call sortArray(tempListbox1)
					Call sortArray(tempListbox2)
					Call removeBlanksFromArray(1)
					Call removeBlanksFromArray(2)
					
					'add the contents of tempListbox1 and 2 to the Listboxes
					DlgListBoxArray "ListBox2", tempListbox2()
					DlgListBoxArray "ListBox1", tempListbox1()
					
					tempListSelect2 = 0 'set to 1st items as default
					bExitMenu = FALSE 'don't close the dilaog
					
				'take all the items from listbox1 and place them in listbox2
				Case "PushButton3"
					ReDim tempListbox2(UBound(sFiles))
					ReDim tempListbox1(0)
					For i = 0 To UBound(sFiles)
						tempListbox2(i) = sFiles(i)
					Next i
					Call sortArray(tempListbox2)
					Call removeBlanksFromArray(2)
					
					'add the contents of tempListbox1 and 2 to the Listboxes
					DlgListBoxArray "ListBox2", tempListbox2()
					DlgListBoxArray "ListBox1", tempListbox1()
					bExitMenu = FALSE  'don't close the dilaog
				
				'take all the items from listbox2 and place them in listbox2
				Case "PushButton4"
					ReDim tempListbox1(UBound(sFiles))
					ReDim tempListbox2(0)
					For i = 0 To UBound(sFiles)
						tempListbox1(i) = sFiles(i)
					Next i
					Call sortArray(tempListbox1)
					Call removeBlanksFromArray(1)
					
					'add the contents of tempListbox1 and 2 to the Listboxes
					DlgListBoxArray "ListBox2", tempListbox2()
					DlgListBoxArray "ListBox1", tempListbox1()
					bExitMenu = FALSE  'don't close the dilaog
				'used to keep track of the values selected from the listbox1 and listbox2 when a button is selected
				Case "ListBox1"
					tempListSelect1 = SuppValue%
					
				Case "ListBox2"
					tempListSelect2 = SuppValue%
				
				'If okbutton is selected check to make sure one item has been selected, it no give a warning and don't close the dialog	
				Case "OKButton1"
					If  tempListbox2(0) = "" Then
						MsgBox "Please select at least one file"
						bExitMenu = FALSE
					Else
						bExitMenu = True
						'bFieldsSelected = True
					End If
					newFilename = dlgSelectFields.TextBox1
					If newFilename = "" Then
						MsgBox "Please enter the new append filename"
						bExitMenu = False
					End If
				'if the cancel button is selected then indicated that no fields have been selected
				Case "CancelButton1"
					'bFieldsSelected = False 'no Fields selected
					bExitScript = true
		End Select
	End Select
	
	'The following is used to enable the different buttons depending on the contents of the listboxes
	If tempListbox1(0) = "" Then 'firt list box is emtpy
		DlgEnable "PushButton1", 0
		DlgEnable "PushButton3", 0
		DlgEnable "PushButton2", 1
		DlgEnable "PushButton4", 1

	ElseIf tempListbox2(0) ="" Then 'second list box is empty
		DlgEnable "PushButton1", 1
		DlgEnable "PushButton3", 1
		DlgEnable "PushButton2", 0
		DlgEnable "PushButton4", 0

	Else 'something in boxes
		DlgEnable "PushButton1", 1
		DlgEnable "PushButton3", 1
		DlgEnable "PushButton2", 1
		DlgEnable "PushButton4", 1

	End If
	
	'close the dialog if bExitMenu is true
	If bExitMenu Then
		funSelectFiles = 0
	Else 
		funSelectFiles = 1
	End If
	
End Function

Function getFiles()
	Dim objFSO As Object
	Dim objFolder As Object
	Dim colFiles As Object
	Dim objFile As Object
	Dim i As Integer
	Dim sTempFilename As String
	
	ReDim sFiles(0)
	i = 0
	
	Set objFSO = CreateObject("Scripting.FileSystemObject")
		
		Set objFolder = objFSO.GetFolder(sFolder)
		
			Set colFiles = objFolder.Files
				For Each objFile In colFiles
					sTempFilename = objFile.Name
					'only add imd files
					'MsgBox UCase(Mid(sTempFilename, Len(sTempFilename) - 3, 3))'
					If UCase(Mid(sTempFilename, Len(sTempFilename) - 2, 3)) = "IMD" Then
						If i = 0 Then 'use for first time through
							sFiles(0) = objFile.Name
							i = 1
						Else
							ReDim preserve sFiles(UBound(sFiles)+1)
							sFiles(UBound(sFiles)) = objFile.Name
						End If
					End If
					 
				Next
			Set objFile = Nothing
			Set colFiles = Nothing
		Set objFolder = Nothing
	Set objFSO = Nothing
	If sFiles(0) = "" Then
		MsgBox "There are no imd files in this directory, script aborted"
		bExitScript = True
	End If
End Function


Private Function sortArray(MyArray() As String)
	Dim lLoop, lLoop2 As Integer
	Dim str1, str2 As String
	For lLoop = 0 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

Function getFolder() 'this one uses the working directory as the highest level directory
	Dim BrowseFolder As String
	Dim oFolder, oFolderItem
	Dim oPath, oShell, strPath
	Dim Current As Variant 'per Windows documentation this is defined as a variant and not a string
	
	
	Set oShell = CreateObject( "Shell.Application" )
	Set oFolder = oShell.Namespace(17) 'the 17 indicates that we are looking at the virtual folder that contains everything on the local computer
	Current = Client.WorkingDirectory()
	Set oFolder = oShell.BrowseForFolder(0, "Please select the folder where the files are located:", 1, Current)
	
	If (Not oFolder is Nothing) Then
		Set oFolderItem = oFolder.Self
		oPath = oFolderItem.Path
		
		If Right(oPath, 1) <> "\" Then
			oPath = oPath & "\"
		End If
	End If
	
	getFolder = oPath
	
	Set oShell = Nothing
	Set oFolder = Nothing
   
End Function

'****************************************************************************************************
'	Name:		removeBlanksFromArray
'	Description:	Routine to remove blank entries to an array
'	Last Update:	
'****************************************************************************************************
Private Function removeBlanksFromArray(tempType As Integer)
	Dim tempArray() As String
	Dim i, ILoop As Integer
	ReDim tempArray(0)
	
	If tempType = 1 Then
		For ILoop = 0 To UBound(tempListbox1)
			If tempListbox1(ILoop) <> "" Then
				tempArray(UBound(tempArray)) = tempListbox1(ILoop) 
				If ILoop <> UBound(tempListBox1) Then 'don't increment on the last pass
					ReDim preserve tempArray(UBound(tempArray) + 1)
				End If
			End If
		Next ILoop
		'MsgBox UBound(MyArray)
		i = UBound(tempArray)
		Erase tempListbox1
	
		ReDim tempListbox1(i)
		For ILoop = 0 To UBound(tempArray)
			'MsgBox "i " & ILoop & " - " & tempArray(ILoop)
			tempListbox1(ILoop) = tempArray(ILoop) 
		Next ILoop
	Else
		For ILoop = 0 To UBound(tempListbox2)
			If tempListbox2(ILoop) <> "" Then
				tempArray(UBound(tempArray)) = tempListbox2(ILoop) 
				If ILoop <> UBound(tempListBox2) Then 'don't increment on the last pass
					ReDim preserve tempArray(UBound(tempArray) + 1)
				End If
			End If
		Next ILoop
		'MsgBox UBound(MyArray)
		i = UBound(tempArray)
		Erase tempListbox2
	
		ReDim tempListbox2(i)
		For ILoop = 0 To UBound(tempArray)
			'MsgBox "i " & ILoop & " - " & tempArray(ILoop)
			tempListbox2(ILoop) = tempArray(ILoop) 
		Next ILoop

	End If

End Function