Error Checking in Excel
Thanks Thanks:  0
Likes Likes:  0
Results 1 to 3 of 3

Thread: Inserting Pictures Automatically

  1. #1
    Board Regular
    Join Date
    Mar 2002
    Location
    Warrington
    Posts
    201
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    Is there any way I can get XL to look in a folder of JPGs and insert and resize each picture in a new cell? Also is there any way it could place the file name for each picture underneath each cell?

    I'm sure I have seen this done in a sort of mini picutre album.

    Please help.

    Cheers

    Matt

  2. #2
    BatCoder
    Join Date
    Feb 2002
    Location
    Turkey
    Posts
    813
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default

    Hi Mattrixdesign,

    Add a new module into the workbook then paste the code below in this module:



    Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindClose Lib "kernel32.dll" (ByVal hFindFile As Long) As Long
    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type
    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * 260
    cAlternate As String * 14
    End Type

    Private Sub FindFiles()
    'Modified code : Reference http://www.vbapi.com
    Dim hsearch As Long
    Dim findinfo As WIN32_FIND_DATA
    Dim success As Long
    Dim buffer As String
    Dim retval As Long

    Dim fileinfo As String 'User defined

    'I used gifs in windows directory
    fileinfo = "C:Windows*.gif"

    hsearch = FindFirstFile(fileinfo, findinfo)
    If hsearch = -1 Then
    Exit Sub
    End If
    Do
    buffer = Left(findinfo.cFileName, InStr(findinfo.cFileName, vbNullChar) - 1)
    ActiveSheet.Pictures.Insert("C:Windows" & buffer).Select
    Selection.Left = 0
    If ActiveSheet.Pictures.Count = 1 Then
    Selection.Top = 0
    Else
    Selection.Top = ActiveSheet.Pictures(ActiveSheet.Pictures.Count - 1).Height + ActiveSheet.Pictures(ActiveSheet.Pictures.Count - 1).Top
    End If
    success = FindNextFile(hsearch, findinfo)
    Loop Until success = 0
    retval = FindClose(hsearch)
    End Sub

    Code locates pictures up to down in sheet. I dont know how you want to resize cells or all pictures are in same size? Please ask for more if you need.


    Suat

  3. #3
    MrExcel MVP Ivan F Moala's Avatar
    Join Date
    Feb 2002
    Location
    Auckland, New Zealand
    Posts
    4,209
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    Her is another option for you just to
    add to Oz good code except no API's

    Running it gives the option to select where
    the Picture files are and what one to load in

    Avail Picture formats are;
    (*.bmp)(*.tif)(*.jpg) but you can change this

    select cell to paste to.

    The prgm current resizes the pict....play
    around with the settings to get what you want


    Ivan

    Sub Insert_Pict()
    Dim oPict, PictObj
    Dim sImgFileFormat As String
    Dim rPictCell As Range
    Dim iAns As Integer

    sImgFileFormat = "jpg Files (*.jpg), *.jpg, bmp (*.bmp),*.bmp,tif (*.tif),*tif"

    GetPict:
    oPict = Application.GetOpenFilename(sImgFileFormat)
    'Note you can load in any nearly file format
    If oPict = False Then End

    iAns = MsgBox("Open : " & oPict, vbYesNo, "Insert Picture")
    If iAns = vbNo Then GoTo GetPict

    'Now paste to UserSelected Cell
    GetCell:
    Set rPictCell = Application.InputBox("Select the cell to insert into", Type:=8)
    If rPictCell.Count > 1 Then MsgBox "Select ONE cell only": GoTo GetCell

    rPictCell.Select
    Set PictObj = ActiveSheet.Pictures.Insert(oPict)
    rPictCell.Offset(-1, 0) = oPict

    With PictObj
    .ShapeRange.LockAspectRatio = msoTrue
    .ShapeRange.Height = 57#
    .ShapeRange.Width = 57#
    End With

    Set PictObj = Nothing
    Set rPictCell = Nothing

    End Sub



Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

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