Selecting non-contiguous files

Airwolf

Board Regular
Joined
Jul 24, 2002
Messages
123
I have the following code to select a FOLDER

Dim objFolder As Object, strPictFullPath As String, strFileName As String
Dim ws As Worksheet, wb As Workbook
Dim OldStaBar As Boolean
Dim ArrImg
Dim z As Integer

'// Define your image Formats here [Change as required]
ArrImg = Array("*.jpg") '("*.bmp", "*.gif", "*.jpg", "*.jpeg", "*.tif", "*.wmf")
Sheets("Photos").Select
'//
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please Select Image Folder", 0, "")

If Not objFolder Is Nothing Then
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
strPictFullPath = objFolder.Items.Item.Path & Application.PathSeparator
Else
strPictFullPath = objFolder.Items.Item.Path
End If
Else
Exit Sub
End If

the routine goes on to embed all JPEG files into cells. I need to be able to select contiguous and non contiguous files rather than the whole folder contents.

Thanks
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Selecting non-contiguous files - Solved

Ok guy's I finally found it using searches and Highlight code press F1

Sub LoadPictureFiles()
Dim objFolder As Object, strPictFullPath As String, strFileName As String
Dim ws As Worksheet, wb As Workbook
Dim OldStaBar As Boolean
Dim ArrImg
Dim z As Integer
Dim ImgPath
Dim Filt As String, Title As String
Dim FilterIndex As Integer

' Set Drive letter
' ChDrive "D:\"
' Set to Specified Path\Folder
' ChDir "D:\photo's"
' Set File Filter
Filt = "Image Files (*.jpg), *.jpg"
' Set *.* FilterIndex to the number of Filters selected
FilterIndex = 1
' Set Dialogue Box Caption
Title = "Please select up to 6 Images"
' Get FileName
ImgPath = Application.GetOpenFilename(FileFilter:=Filt, _
FilterIndex:=FilterIndex, Title:=Title, ButtonText:="", MultiSelect:=True)
' Exit if Dialogue box cancelled
If ImgPath(1) = False Then
MsgBox "No File was selected", vbOKOnly & vbCritical, "Selection Error"
Exit Sub
End If


'// Clear Old Data
DeletePicts
'// Setup Status
OldStaBar = Application.DisplayStatusBar
Application.StatusBar = True
ActiveSheet.Unprotect
x = 4
For z = 1 To UBound(ImgPath)
strFileName = Dir(ImgPath(z))
If strFileName = "" Then MsgBox "No " & ImgPath(z) & " files exist" & _
"", iMsgStyle: GoTo Again

'// Lets get the list
Do Until x = 10 Or strFileName = ""
'On Error GoTo ErrH
Cells(14, x).Select


On Error Resume Next
ActiveCell.Comment.Delete
Err.Clear
With ActiveCell.AddComment '(strFileName)
With .Shape
.Height = 215
.Width = 310
.Fill.UserPicture (strFileName)
.Text
End With
End With
Cells(14, x) = Left(strFileName, Len(strFileName) - 4)
' Cells(15, x) = FileDateTime(strPictFullPath & strFileName)

Application.StatusBar = "File#:" & x - 1 & " " & strPictFullPath & strFileName
strFileName = Dir()
x = x + 1
Loop

Again:
Next

Reset:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = False 'OldStaBar
End With
ActiveSheet.Protect

Exit Sub
ErrH:

MsgBox Err.Number & vbCr & _
Err.Description & vbCr _
, vbMsgBoxHelpButton _
, "Error Accessing: " & strFileName _
, Err.HelpFile _
, Err.HelpContext

End Sub

The operative bit I was after was
ImgPath = Application.GetOpenFilename(FileFilter:=Filt, _
FilterIndex:=FilterIndex, Title:=Title, ButtonText:="",_ MultiSelect:=True)

I can now select any files, any number of files and even re-name b4 selecting
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,185
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top