VBA Import Multiple photos from User Form Button

[District Engineer]

Developed a VBA user form to capture site data from our site operatives, customer info, job details which then writes to a datasheet which we use for import into a database to track progress of job etc

This is complete & been in use for 6 months.

Im no VBA expert (Civil Engineer) but managed to get this far with web support and few bits of code from inhouse guy.

Would like to add new photo import feature so all data is captured within the JOB.xls and saves having to rename site photos & transferring files etc

Have added "Import Photo" button to User form and trying to find code so inserts multiple photos from a folder on the hard drive "c:\data\PHOTOS"

Have created a new Worksheet "PHOTOS" and want to paste them in structured (say 2 pics side x side 640x480) listing them automatically down the page - unlikely to be more than a dozen pictures.

Have got this far lol !!

Private Sub IMPORT_PHOTOS_Click()


End Sub

Have got as far as opening dialoge box with a GET_data routine which opens dialogue box at correct folder location - but wont do anything else lol

Any help greatly appreciated - my usual inhouse support on holiday at moment and deadline of friday looming - typical !!

Cheers

Ian

 

[Gary McMaster]

Hi Ian,

Maybe like this?

Public Sub Test()

Dim vFileList As Variant
Dim vFileName As Variant
Dim oInsertAt As Range
Dim iRowOffset As Integer
Dim iColOffset As Integer
Dim bNewRow As Boolean
Dim oShape As Shape

iRowOffset = 20 ' Set this number to desired row spacing
iColOffset = 10 ' Set this number to desired column spacing

Set oInsertAt = ActiveSheet.Range("B12")  'Upper left corner first picture here

vFileList = Application.GetOpenFilename("Graphics Files (*.jpg; *.gif),*.jpg;*.gif", , "Select Files", , True)

For Each vFileName In vFileList

    Set oShape = ActiveSheet.Shapes.AddPicture(vFileName, msoFalse, msoTrue, oInsertAt.Left, oInsertAt.Top, 1, 1)
    oShape.ScaleHeight 1, msoTrue
    oShape.ScaleWidth 1, msoTrue
    
    If bNewRow = True Then
        Set oInsertAt = oInsertAt.Offset(iRowOffset, (iColOffset * -1))
        bNewRow = False
    Else
        Set oInsertAt = oInsertAt.Offset(0, iColOffset)
        bNewRow = True
    End If
    
Next vFileName

End Sub

 

[District Engineer]

Brill Gary Mc i am almost there, tweaked it to make "PHOTOS" worksheet active and set DIR path so constant directory path

Just getting runtime error 13 'Type Mismatch'

on

For Each vFileName In vFileList

Any ideas

Thanks for help so far real life saver !!!

Ian


Private Sub IMPORT_PHOTOS_Click()
Dim vFileList As Variant
Dim vFileName As Variant
Dim oInsertAt As Range
Dim iRowOffset As Integer
Dim iColOffset As Integer
Dim bNewRow As Boolean
Dim oShape As Shape
iRowOffset = 15 ' Set this number to desired row spacing
iColOffset = 5 ' Set this number to desired column spacing
' Make sheet PHOTOS active for import routine IM
Sheets("PHOTOS").Activate
Set oInsertAt = ActiveSheet.Range("B12") 'Upper left corner first picture here
' Change Directory to Job flooder photos on toughbook hard drive IM
ChDrive "C:\"
ChDir "C:\DATA\PHOTOS"
vFileList = Application.GetOpenFilename("Graphics Files (*.jpg; *.gif),*.jpg;*.gif", , "Select Files", , True)
If vFileList = False Then MsgBox "No file specified.", vbExclamation, "No Photos Selected???"

For Each vFileName In vFileList
Set oShape = ActiveSheet.Shapes.AddPicture(vFileName, msoFalse, msoTrue, oInsertAt.Left, oInsertAt.Top, 1, 1)
oShape.ScaleHeight 1, msoTrue
oShape.ScaleWidth 1, msoTrue

If bNewRow = True Then
Set oInsertAt = oInsertAt.Offset(iRowOffset, (iColOffset * -1))
bNewRow = False
Else
Set oInsertAt = oInsertAt.Offset(0, iColOffset)
bNewRow = True
End If

Next vFileName
End Sub

 

[Gary McMaster]

If vFileList = False Then MsgBox "No file specified.", vbExclamation, "No Photos Selected???"

The above line is just "falling thru" and trying to execute the rest of the code if the file list is empty. It should be more like this:

If vFileList = False Then
    MsgBox "No file specified.", vbExclamation, "No Photos Selected???"
    Exit Sub
End If

Gary