Help! Need macro to insert multiple pics, resize and then fit into particular group of cells

Thanks Thanks:  0
Likes Likes:  0
Results 1 to 2 of 2

Thread: Help! Need macro to insert multiple pics, resize and then fit into particular group of cells

  1. #1
    New Member
    Join Date
    Jun 2014
    Posts
    17
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Question Help! Need macro to insert multiple pics, resize and then fit into particular group of cells

     
    Hi all,

    Need help please...

    The macro I have, opens the 'insert pic' dialogue box, allows user to only insert/select 1 pic, then a box pops up and confirms if you want to insert it, and then another box pops up and prompts you to specify which cell you want it inserting into, and it resizes it to the size I have specified in the macro.

    I now need to edit it to change the following:

    - Now to allow multiple pics to be inserted at the same time
    - Position them into certain group of cells i.e. A1, A2, A3, A4, A5, etc.... (so basically each pic that has been inserted will go into each one of those cells, but somehow I need it to be endless because different users will insert different amount of pics).
    - I want to remove the additional dialogue boxes that pop up.


    This is my current code:

    Sub INSERTPICANDRESIZE()

    Dim Pict
    Dim ImgFileFormat As String
    Dim PictCell As Range
    Dim Ans As Integer




    ImgFileFormat = "jpg (*.jpg),*.jpg"




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




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




    'Now paste to userselected cell
    GetCell:
    Set PictCell = Application.InputBox("Select the cell to insert into", Type:=8)
    If PictCell.Count > 1 Then MsgBox "Select ONE cell only": GoTo GetCell
    PictCell.Select
    ActiveSheet.Pictures.Insert(Pict).Select
    Selection.ShapeRange.Height = 270.1417322835






    End Sub

    Please help.

    Thank you

  2. #2
    Board Regular
    Join Date
    Dec 2012
    Location
    SoCal
    Posts
    512
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Help! Need macro to insert multiple pics, resize and then fit into particular group of cells

      
    Quote Originally Posted by MISS_AJAZ View Post
    Hi all,

    Need help please...

    The macro I have, opens the 'insert pic' dialogue box, allows user to only insert/select 1 pic, then a box pops up and confirms if you want to insert it, and then another box pops up and prompts you to specify which cell you want it inserting into, and it resizes it to the size I have specified in the macro.

    I now need to edit it to change the following:

    - Now to allow multiple pics to be inserted at the same time
    - Position them into certain group of cells i.e. A1, A2, A3, A4, A5, etc.... (so basically each pic that has been inserted will go into each one of those cells, but somehow I need it to be endless because different users will insert different amount of pics).
    - I want to remove the additional dialogue boxes that pop up.


    This is my current code:

    Sub INSERTPICANDRESIZE()

    Dim Pict
    Dim ImgFileFormat As String
    Dim PictCell As Range
    Dim Ans As Integer




    ImgFileFormat = "jpg (*.jpg),*.jpg"




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




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




    'Now paste to userselected cell
    GetCell:
    Set PictCell = Application.InputBox("Select the cell to insert into", Type:=8)
    If PictCell.Count > 1 Then MsgBox "Select ONE cell only": GoTo GetCell
    PictCell.Select
    ActiveSheet.Pictures.Insert(Pict).Select
    Selection.ShapeRange.Height = 270.1417322835






    End Sub

    Please help.

    Thank you
    MISS_AJAZ,
    This code will load ALL the pictures in the folder to the sheet you designate.
    I copied it from the following link:
    Excel-VBA : Insert Multiple Images from a Folder to Excel Cells
    Perpa

    Code:
    Sub AddOlEObject()
    
        Dim mainWorkBook As Workbook
        Application.ScreenUpdating = False
        Set mainWorkBook = ActiveWorkbook
        Sheets("Object").Activate           'Change the sheet name from "Object" to the sheet name where you want your pictures to go
        Folderpath = "C:\Users\you\folder1"    'Change the folderpath to wherever your pictures are coming from
        Set fso = CreateObject("Scripting.FileSystemObject")
        NoOfFiles = fso.GetFolder(Folderpath).Files.Count
        Set listfiles = fso.GetFolder(Folderpath).Files
        For Each fls In listfiles
           strCompFilePath = Folderpath & "\" & Trim(fls.Name)
            If strCompFilePath <> "" Then
                If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
                Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
                Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                    counter = counter + 1
                    Sheets("Object").Range("A" & counter).Value = fls.Name
                    Sheets("Object").Range("B" & counter).ColumnWidth = 18     'Adjust to fit your pictures
                    Sheets("Object").Range("B" & counter).RowHeight = 80           'Adjust to fit your pictures
                    Sheets("Object").Range("B" & counter).Activate
                    Call insert(strCompFilePath, counter)
                    Sheets("Object").Activate
                End If
            End If
        Next
    mainWorkBook.Save
    Application.ScreenUpdating = True
    End Sub
    
    Function insert(PicPath, counter)
    'MsgBox PicPath
        With ActiveSheet.Pictures.insert(PicPath)
            With .ShapeRange
                .LockAspectRatio = msoTrue
                .Width = 50      'Adjust to change the WIDTH of your pictures
                .Height = 70     'Adjust to change the HEIGHT of your pictures
            End With
            .Left = ActiveSheet.Range("B" & counter).Left
            .Top = ActiveSheet.Range("B" & counter).Top
            .Placement = 1
            .PrintObject = True
        End With
    End Function

User Tag List

Tags for this Thread

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
  •  

 

 
DMCA.com