+ Reply to Thread
Results 1 to 2 of 2

Import Multiple Folders

  1. #1
    Registered User
    Join Date
    02-09-2016
    Location
    İstanbul
    MS-Off Ver
    Version 6.1.7601
    Posts
    1

    Import Multiple Folders

    Hello everyone,

    I have a script to import multiple files ignoring the file type however it stops in case 5. Can you please clear me why and how can i fix it.

    Here the script;

    Dim listbox1$()
    Dim listbox2$()
    Dim mylist$()
    Dim templatelist() AS string

    Begin Dialog NewDialog 50,40,326,142,"Choose Files:", .superdialog
    ListBox 12,10,134,90, listbox1$(), .ListBox1
    ListBox 177,12,134,89, listbox2$(), .ListBox2
    CancelButton 227,114,40,14, "Cancel", .CancelButton1
    OKButton 272,114,40,14, "OK", .OKButton1
    PushButton 150,26,19,14, ">", .rightbtn
    PushButton 149,50,21,14, "<", .leftbtn
    GroupBox 5,5,312,101, .GroupBox1
    End Dialog

    Begin Dialog BoxExample 15,35,160,72,"Choose File Type:"
    OKButton 108,37,40,14
    CancelButton 64,37,40,14
    DropListBox 14,22,130,10, mylist$(), .DropListBox1
    Text 7,5,126,9, "Please choose the file types you wish to import:"
    End Dialog

    Begin Dialog NewDialog1 50,40,167,63,"Selection", .NewDialog1
    OKButton 109,34,40,14, "OK", .OKButton1
    CancelButton 62,34,40,14, "Cancel", .CancelButton1
    DropListBox 15,18,135,10, templatelist(), .DropListBox1
    Text 14,9,76,8, "Please Choose Template File:", .Text1
    End Dialog
    Public files()

    Sub main
    On Error GoTo error_handler

    Dim extension As String
    Dim picked_folder As String
    Dim i As Integer
    Dim objFSO As Object
    Dim objFile As Object
    Dim task As Object
    Dim field As Object
    Dim tableDef As Object
    Dim WshShl
    Dim fieldrow_bool As Boolean
    Dim chosentemplate As String

    Dim MyList2$ (9)

    MyList2(0) = "dbf"
    MyList2(1) = "xls"
    MyList2(2) = "mdb"
    MyList2(3) = "xml"
    MyList2(4)= "asc"
    MyList2(5)= "txt"
    MyList2(6)= "csv"
    MyList2(7)= "dat"
    MyList2(8)= "prn"
    MyList2(9)= "pdf"


    extension = choose_extension()
    If extension = -1 Then Exit Sub

    picked_folder = browsefolder()
    If Not Len(picked_folder) > 0 Then GoTo exit_sub

    'Load Array

    If (FindFiles(picked_folder & "\", mylist2(extension), files) = True) Then

    x = UBound(files)

    ReDim listbox1$(x)
    ReDim listbox2$(x)

    For i = 0 To x
    listbox1$(i) = files(i)
    Next

    Dim mydialog As newdialog

    Do

    button = Dialog(mydialog)

    '------- If button pressed and list isn't empty

    If button = 1 And mydialog.listbox1 <> -1 Then
    chosenfile = mydialog.listbox1
    chosentxt = listbox1$(chosenfile)

    z = 0

    Do Until listbox2$(z) = ""
    z = z + 1
    Loop

    listbox2$(z) = chosentxt
    listbox1$(chosenfile) = ""

    End If


    If button = 2 And mydialog.listbox2 <> -1Then

    chosenfile = mydialog.listbox2
    chosentxt = listbox2$(chosenfile)


    '------ This part looks for the first empty slot to input the selection


    z = 0
    Do Until listbox1$(z) = ""
    z = z + 1
    Loop

    '-------- Copies to the first empty slot and clears the selection from the selection list

    listbox1$(z) = chosentxt
    listbox2$(chosenfile) = ""

    End If

    cleanup_listbox1
    cleanup_listbox2


    '------- Loops until Ok or Cancel is clicked

    Loop Until button < 1

    If button = 0 Then GoTo exit_sub

    z = 0

    x = UBound(listbox2$)


    '---------- Count Values in Listbox2$ array and reinitialize array with new dimensions.

    For i = 0 To x

    If listbox2$(z) <> "" Then
    z = z + 1
    End If

    Next


    ReDim preserve listbox2$(z - 1)

    x = UBound(listbox2$)


    Select Case extension

    Case 0
    '------- Run through select statement for each file (i)

    For i = 0 To x

    ' Set-up the dBASE import task
    Set task = Client.GetImportTask("DBaseImport")
    task.InputFileName (picked_folder & "\" & listbox2$(i))

    sample_prefix = Left(listbox2$(i), (Len(listbox2$(i)) - Len( mylist2(extension)) - 1)) ' Removes Extension
    task.OutputFileName = Client.UniqueFileName(sample_prefix)

    ' Execute the task
    task.PerformTask
    Set task = Nothing

    Next

    Case 1


    fieldrow = MsgBox("Is the first row field names?", 4)
    If fieldrow = 6 Then fieldrow_bool = "true" Else fieldrow_bool= "false"


    For i = 0 To x

    ' Set-up the Excel import task
    Set task = Client.GetImportTask("ImportExcel" )

    task.FirstRowIsFieldName = fieldrow_bool
    task.FileToImport = picked_folder & "\" & listbox2$(i)


    sample_prefix = Left(listbox2$(i), (Len(listbox2$(i)) - Len( mylist2(extension)) - 1)) ' Removes Extension
    task.OutputFilePrefix = sample_prefix

    task.EmptyNumericFieldAsZero = FALSE
    task.UniqueFilePrefix

    'Execute the import
    task.PerformTask

    Set task = Nothing

    Next




    Case 2

    For i = 0 To x

    Set task = Client.GetImportTask("Access")
    task.InputFileName = picked_folder & "\" & listbox2$(i)

    sample_prefix = Left(listbox2$(i), (Len(listbox2$(i)) - Len( mylist2(extension)) - 1)) ' Removes Extension
    task.OutputFileNamePrefix = task.UniqueFileNamePrefix(sample_prefix)

    task.DetermineMaximumCharacterFieldLengths = SCAN_ALL
    task.AddAllTables

    ' Execute the Access import task
    task.PerformTask
    Set task = Nothing

    Next

    Case 3

    For i = 0 To x

    ' Set-up the XML import task
    Set task = Client.GetImportTask("ImportXML")
    task.InputFileName = picked_folder & "\" & listbox2$(i)

    sample_prefix = Left(listbox2$(i), (Len(listbox2$(i)) - Len( mylist2(extension)) - 1)) ' Removes Extension
    task.OutputFileName = task.UniqueBaseFileName(sample_prefix)

    ' Execute the XML import task
    task.PerformTask
    Set task = Nothing

    Next

    Case 5

    chosentemplate =choose_template(picked_folder, "rdf")

    If Not Len(chosentemplate) > 0 Then
    MsgBox "RDF File Not Chosen. Cannot Continue."
    GoTo exit_sub
    End If


    For i = 0 To x


    sample_prefix = Left(listbox2$(i), (Len(listbox2$(i)) - Len( mylist2(extension)) - 1)) ' Removes Extension
    dbName = client.uniquefilename(sample_prefix)
    eqn = ""
    Client.ImportDatabase picked_folder & "\" & listbox2$(i), dbName, False, FALSE, eqn, chosentemplate


    Next

    Case 4, 6

    fieldrow = MsgBox("Is the first row field names?", 4)

    If fieldrow = 6 Then
    fieldrow_bool = 1
    Else
    fieldrow_bool= 0
    End If

    chosentemplate =choose_template(picked_folder, "rdf")

    If Not Len(chosentemplate) > 0 Then
    MsgBox "RDF File Not Chosen. Cannot Continue."
    GoTo exit_sub
    End If

    For i = 0 To x

    sample_prefix = Left(listbox2$(i), (Len(listbox2$(i)) - Len( mylist2(extension)) - 1)) ' Removes Extension
    dbName = client.UniqueFileName(sample_prefix)
    eqn = ""
    Client.ImportDelimfile picked_folder & "\" & listbox2$(i), dbName, False, eqn, chosentemplate, fieldrow_bool


    Next

    Case 7

    chosenFdf =choose_template(picked_folder, "fdf")

    If Not Len(chosenFdf) > 0 Then
    MsgBox "FDF File Not Chosen. Cannot Continue."
    GoTo exit_sub
    End If

    For i = 0 To x

    filename = picked_folder & "\" & listbox2$(i)

    Set task = Client.GetImportTask("AS400")
    task.InputFDFFileName = client.locateinputfile(chosenFdf)
    ' Set-up the AS400 import task

    sample_prefix = Left(listbox2$(i), (Len(listbox2$(i)) - Len( mylist2(extension)) - 1)) ' Removes Extension
    dbName = client.UniqueFileName(sample_prefix)
    task.OutputFileName = dbName
    task.InputDATFilename = client.locateinputfile(filename)

    ' Execute the AS400 import task
    task.PerformTask
    Set task = Nothing

    Next
    Case 8, 9


    chosenjpm =choose_template(picked_folder, "jpm")

    If Not Len(chosenjpm) > 0 Then
    MsgBox "JPM File Not Chosen. Cannot Continue."
    GoTo exit_sub

    End If



    For i = 0 To x
    filename = picked_folder & "\" & listbox2$(i)
    sample_prefix = Left(listbox2$(i), (Len(listbox2$(i)) - Len( mylist2(extension)) - 1)) ' Removes Extension
    dbName = client.UniqueFileName(sample_prefix)
    Client.ImportPrintReport chosenjpm, filename, dbName, false

    Next



    End Select


    Else

    MsgBox "No Files of " & mylist2(extension) & " type Found"

    End If



    exit_sub:

    Set task = Nothing

    Client.RefreshFileExplorer



    Exit Sub



    error_handler:
    MsgBox err.description
    GoTo exit_sub

    End Sub



    Function choose_extension()

    ' --------- Define an array of items for List Box, Combo Box, and Drop-Down Combo Box

    ReDim MyList$ (9)
    MyList (0) = "dBase"
    MyList (1) = "Excel"
    MyList (2) = "Access"
    MyList (3) = "XML"
    MyList (4) ="ASCII - .ASC"
    MyList (5) ="ASCII - .TXT"
    MyList (6) ="ASCII - .CSV"
    MyList (7) ="AS400"
    MyList (8) ="Print Report"
    MyList (9) ="Adobe PDF"


    '--------- Define and display dialog box
    Dim Dlg1 As BoxExample
    Button = Dialog (Dlg1)


    choose_extension = dlg1.DropListBox1

    If Button = -1 Then

    choose_extension = dlg1.DropListBox1

    Else

    choose_extension = -1

    End If



    End Function

    Function BrowseFolder()
    Dim oFolder, oFolderItem
    Dim oPath, oShell, strPath

    Set oShell = CreateObject( "Shell.Application" )
    Set oFolder = oShell.Namespace(17)
    Set oFolderItem = oFolder.Self
    strPath = oFolderItem.Path

    msg = "Please select your working directory where"
    msg = msg & Chr(10) & "the template and databases are located:"

    Set oFolder = oShell.BrowseForFolder(0, msg, 512, strPath)

    If oFolder Is Nothing Then
    BrowseFolder = ""
    Exit Function
    End If

    Set oFolderItem = oFolder.Self
    oPath = oFolderItem.Path

    BrowseFolder = oPath
    End Function


    Private Function FindFiles(path As String, ext As String, files())

    Dim ffile As String
    ffile = Dir$(path & "*." & ext)


    If Len(ffile) = 0 Then Exit Function

    '-------- Dir ext = *.ext* fixing by checking length
    Do

    firstbackspace = strReverse (ffile)
    firstbackspacenum = InStr(1,firstbackspace, ".")
    importname = Right(ffile, firstbackspacenum - 1)

    If Len(importname) = Len(ext) Then

    If Not IsNull(ffile) Then

    '-------- If one value found return function true and redim array
    If (FindFiles = False) Then
    ReDim files(0)
    FindFiles = True
    Else

    ReDim Preserve files(UBound(files) + 1)

    End If


    files(UBound(files)) = ffile


    Else
    Exit Do
    End If

    End If

    ffile = Dir

    Loop Until Len(ffile) = 0

    End Function

    Private Function choose_template(path As String, ext As String) As String



    Dim ffile As String

    ffile = Dir$(path & "\*." & ext)

    If Len(ffile) = 0 Then

    MsgBox " No Template Files Found." & Chr(10) & Chr(13) & Chr(10) & Chr(13) & " Template Files must be in the"& Chr(10) & Chr(13) & "same folder as the source files.",0 , "Need Template"
    choose_template = ""
    Exit Function


    End If

    ReDim templatelist(0)


    Do Until Len(ffile) = 0


    templatelist(UBound(templatelist)) = ffile

    ReDim Preserve templatelist(UBound(templatelist) + 1)
    ffile = Dir

    Loop


    Dim dlg3 As NewDialog1

    Do

    button = Dialog(dlg3)

    Loop Until button < 1

    If button = 0 Then
    choose_template = ""

    Exit Function

    End If



    choose_template = path & "\" & templatelist(dlg3.DropListBox1)


    End Function


    Sub cleanup_listbox1

    x = UBound(listbox1$)
    For i = 0 To x
    z = i
    zzz = listbox1$(z)

    If Len(zzz) = 0 Then
    Do While Len(zzz) = 0 And z <> x + 1
    listbox1$(i) = listbox1$(z)
    listbox1$(z) = ""
    z = z + 1
    zzz = listbox1$(i)
    Loop
    End If
    Next


    End Sub

    Sub cleanup_listbox2

    x = UBound(listbox2$)
    For i = 0 To x
    z = i
    zzz = listbox2$(z)

    If Len(zzz) = 0 Then
    Do While Len(zzz) = 0 And z <> x + 1
    listbox2$(i) = listbox2$(z)
    listbox2$(z) = ""
    z = z + 1
    zzz = listbox2$(i)
    Loop
    End If
    Next


    End Sub

  2. #2
    Forum Guru xladept's Avatar
    Join Date
    04-14-2012
    Location
    Pasadena, California
    MS-Off Ver
    Excel 2003,2010
    Posts
    12,378

    Re: Import Multiple Folders

    Hi armans,

    Welcome to the Forum!

    Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

    Posting code between [CODE]Please [url=https://www.excelforum.com/login.php]Login or Register [/url] to view this content.[/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

    Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here
    If I've helped you, please consider adding to my reputation - just click on the liitle star at the left.

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~(Pride has no aftertaste.)

    You can't do one thing. XLAdept

    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~aka Orrin

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. Use Excel VBA to Copy multiple files from different source folders to different folders
    By mm1234mail in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 06-12-2014, 01:17 PM
  2. [SOLVED] Create folders and Sub folders and Sub-Sub folders from 5 columns with VBA
    By arleutwyler in forum Excel Programming / VBA / Macros
    Replies: 5
    Last Post: 03-11-2014, 04:16 PM
  3. [SOLVED] Import files from external folders
    By hyperaura in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 05-22-2013, 05:35 AM
  4. [SOLVED] Import multiple text files from multiple folders
    By gshock in forum Excel Programming / VBA / Macros
    Replies: 6
    Last Post: 02-01-2013, 03:49 PM
  5. Replies: 0
    Last Post: 12-04-2012, 01:01 PM
  6. Macro to Parse Text - Import text to Excel from Multiple Text Files & Folders
    By Novice_To_Excel in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 10-02-2012, 01:05 AM
  7. Import 50-100 xml files from multiple folders
    By TENNISMAN in forum Excel General
    Replies: 1
    Last Post: 08-08-2007, 11:51 AM

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1