Additional Folder to Search

[D Willett]

Hi Guys, been away for a while.
I have a VB6 routine requiring a tweak, the following code loads images into a listbox control:

Code: Select all

Private Sub cmdImportAF_Click()
    Const MYCOMPUTER As String = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}"
    On Error GoTo cError

    Dim i      As Integer
    Dim myFiles() As String
    Dim myPath As String


    ClearList

    With cmnDialog1
        .MaxFileSize = 32000    'this will max out the buffer for the filenames array for large selections. *NEW*
        .CancelError = False    'if cancel is pressed, the code jumps to cError because of the On Error statement above
        .Filter = "JPG Files (*.jpg;*.jpeg)|*.jpg;*.jpeg"
        'Text Files (*.txt)|*.txt|Graphic Files (*.bmp;*.gif;*.jpg)|*.bmp;*.gif;*.jpg|All Files (*.*)|*.*
        .FilterIndex = 2
        .FileName = ""
        .InitDir = MYCOMPUTER
        .Flags = CD_FLAGS    'this is where we tell it to use multiselect
        .ShowOpen
        myFiles = Split(.FileName, vbNullChar)    'the Filename returned is delimeted by a null character because we selected the cdlOFNLongNames flag

        Select Case UBound(myFiles)
            Case 0    'if only one was selected we are done
                lstImages.AddItem myFiles(0)
            Case Is > 0    'if more than one, we need to loop through it and append the root directory
                For i = 1 To UBound(myFiles)
                    myPath = myFiles(0) & IIf(Right(myFiles(0), 1) <> "\", "\", "") & myFiles(i)
                    lstImages.AddItem myPath
                Next i
        End Select
        Me.txtFileCount.Text = "Total Images In Folder" & "  " & Me.lstImages.ListCount
    End With
    Exit Sub



cError:
    Beep
    MsgBox Err.Description  '*NEW*
End Sub

myPath needs to drill down one more folder "_IMAGES" and retrieve any images in that folder too, the folder is added by a third party software company and the name of the folder is always the same.
So the current code will see for example:

L:\mmpdf\consolefiles\12345

The change in the code would need to see:

L:\mmpdf\consolefiles\12345\_IMAGES

Obviously that is if the _IMAGES folder exists which it doesn't in all occasions.
Would anyone mind tweaking the routine for this to happen/

Many Thanks.

[HansV]

Hi Dave,

If I understand the code correctly, it does not loop through all files in a folder, but prompts the user to select files. If so, it is up to the user to select files form a subfolder...

[D Willett]

Hi Hans

Yes of course I see that now. Then I have to look elsewhere for the code (it does exist) which is already in the project somewhere, I'm looking in the wrong place...

Cheers

[D Willett]

I believe it's this routine which would do the trick then:
'strPath' looks to be the correct line of code, but I will test it.

Code: Select all

Private Function AFImageFetch()
    Dim fso    As New Scripting.FileSystemObject
    Dim fld    As Scripting.Folder
    Dim fil    As Scripting.File
    Dim strPath As String
    Dim strTrans5 As String
    Dim lngCount As Long


    [b]strPath = modConfig.locConsoleFiles & "\" & Me.txtEst & "\_IMAGES\"[/b]

    strTrans5 = Me.txtEst.Text
    Me.lstDragDrop.Clear


    If fso.FolderExists(strPath) Then
        Set fld = fso.GetFolder(strPath)
        lngCount = 0


        For Each fil In fld.Files
            Select Case Right(fil.Name, 3)

                Case "jpg"
                    If Not fil.Name Like strTrans5 & "*" Then
                        lngCount = lngCount + 1
                        'MsgBox fil.Name
                        Me.lstDragDrop.AddItem strPath & fil.Name

                    End If

                Case "jpeg"
                    If Not fil.Name Like strTrans5 & "*" Then
                        lngCount = lngCount + 1
                        'MsgBox fil.Name
                        Me.lstDragDrop.AddItem strPath & fil.Name
                    End If

                Case "pdf"
                    If Not fil.Name Like strTrans5 & "*" Then
                        lngCount = lngCount + 1
                        'MsgBox fil.Name
                        Me.lstDragDrop.AddItem strPath & fil.Name
                    End If



                Case Else

            End Select


        Next fil
        If lngCount > 0 Then
            Me.txtTransAF.Text = lngCount
            TransferAFFiles
        End If
    End If


    Set fil = Nothing
    Set fld = Nothing
    Set fso = Nothing
End Function

[HansV]

Good luck!

[D Willett]

Tested and working ( for now )

Thanks for always making me look further Hans

[HansV]