Skip to main content

Append multiple files from same folder

I had a request from another posting about a script that would append multiple files from the same folder.  I had already created one in the past but it lacked any user input, I have changed that with this one.  So once you run the script you will have a message saying all the idea files should be stored in the same folder under the project directory.  You will then have an input box that will ask you the filename for the new file (don't add the file extension).  The script will then read all the IDEA files in that directory and append them together.


Option Explicit
Dim sFolder As String
Dim sFilename As String
Const EXTENSION = "*.IMD"
Dim workingFolder As String
Sub Main 
	workingFolder =Client.WorkingDirectory() 
	MsgBox "All the files should be stored in the same folder under the project folder, all IMD files will be appended from that folder"
	sFolder = getFolder()
	sFilename = InputBox("Please entere the append filename (do not add the extension)", "Enter filename", "")
	Call importFiles()
	client.refreshFileExplorer
End Sub
Function importFiles() 
	Dim Files As String 
	Dim filename As String 
	Dim dbName As String 
	Dim db As database
	Dim task As task
	Files = Dir(sFolder & EXTENSION) 
	Dim bFirstPassInd As Boolean  
	bFirstPassInd = true 
	'MsgBox sFolder & Files
	Set db = Client.OpenDatabase(sFolder & Files)
	Set task = db.AppendDatabase
	Files = Dir 
	Do  
		' Get the next file name and place it in FileList.  
		If Len(Files) > 1 Then  
			'MsgBox sFolder & Files
			task.AddDatabase sFolder & Files
		End If  
		Files = Dir 
	Loop While Files <> ""
	dbName = client.uniquefilename(sFilename)
	task.PerformTask dbName, ""
	Set task = Nothing
	Set db = Nothing
	Client.OpenDatabase(dbName)
	Set db = Nothing
	Set task = Nothing
End Function

'****************************************************************************************************
'	Name:		getFolder
'	Description:	Routine to obtain the folder
'	Last Update:
'	Returns:		the folder path
'****************************************************************************************************
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

End Function
The website encountered an unexpected error. Try again later.