Excel VBA To Insert Multiple Images From A Folder To Worksheet

 


VBA Code -

Option Explicit

Private Sub btnInsertPictures_Click()

    Dim photo As Shape

    Dim ImgNameCol As Integer, ImgCol As Integer

    Dim CCol As Integer, TCol As Integer

    Dim CRow As Integer, TRow As Integer

    Dim Ws As Worksheet

    Dim imgno As Integer

    imgno = 1

    Set Ws = ActiveWorkbook.Sheets(Me.cmbSheets.Text)

    '************ delete all images **************

    Dim Shp As Shape

    For Each Shp In Ws.Shapes

        If VBA.Left(Shp.Name, 8) = "EmpImage" Then

            Shp.Delete

        End If

    Next Shp

    '*********************************************

    CRow = Me.txtHeadingRow.Text

    TCol = Ws.Cells(CRow, Columns.Count).End(xlToLeft).Column

    For CCol = 1 To TCol

        If Ws.Cells(CRow, CCol).Value = Me.cmbPicturesName.Text Then

            ImgNameCol = CCol

            GoTo EX1

        End If

    Next CCol

EX1:

    For CCol = 1 To TCol

        If Ws.Cells(CRow, CCol).Value = Me.cmbImageColumn.Text Then

            ImgCol = CCol

            GoTo EX2

        End If

    Next CCol

EX2:

    TRow = Ws.Cells(Rows.Count, ImgNameCol).End(xlUp).Row

    Dim tmpCRow As Long

    Dim Filename As String

    For tmpCRow = CRow + 1 To TRow

        Filename = Me.txtImagePath.Text & "\" & Ws.Cells(tmpCRow, ImgNameCol).Value & ".jpg"

        If VBA.Dir(Filename) <> "" Then

            Set photo = Ws.Shapes.AddPicture(Filename, msoFalse, msoTrue, Ws.Cells(tmpCRow, ImgCol).Left, Ws.Cells(tmpCRow, ImgCol).Top, Ws.Cells(tmpCRow, ImgCol).Width, Ws.Cells(tmpCRow, ImgCol).Height)

        Else

            Set photo = Ws.Shapes.AddPicture(Me.txtImagePath.Text & "\No Image.jpg", msoFalse, msoTrue, Ws.Cells(tmpCRow, ImgCol).Left, Ws.Cells(tmpCRow, ImgCol).Top, Ws.Cells(tmpCRow, ImgCol).Width, Ws.Cells(tmpCRow, ImgCol).Height)

        End If

        With photo

            .Name = "EmpImage" & Ws.Cells(tmpCRow, ImgNameCol).Value

           .LockAspectRatio = msoFalse

           .Placement = 1

        End With

        imgno = imgno + 1

    Next tmpCRow

    Ws.Activate

    Unload Me

    MsgBox ("Done")

End Sub

 

Private Sub btnSelectImagePath_Click()

    Dim folderDialog As FileDialog

    Dim selectedFolder As Variant

    Set folderDialog = Application.FileDialog(msoFileDialogFolderPicker)

    folderDialog.Title = "Select a Folder"

    If folderDialog.Show = -1 Then

        selectedFolder = folderDialog.SelectedItems(1)

        Me.txtImagePath.Text = selectedFolder

    End If

End Sub

 

Private Sub txtHeadingRow_AfterUpdate()

    Me.cmbImageColumn.Clear

    Me.cmbPicturesName.Clear

    Dim ActSheet As Worksheet

    Dim CRow As Integer, CCol As Integer, TCol As Integer

    Set ActSheet = ActiveWorkbook.Sheets(Me.cmbSheets.Text)

    CRow = Me.txtHeadingRow.Text

    TCol = ActSheet.Cells(CRow, Columns.Count).End(xlToLeft).Column

    For CCol = 1 To TCol

        If ActSheet.Cells(CRow, CCol).Value <> "" Then

            Me.cmbImageColumn.AddItem (ActSheet.Cells(CRow, CCol).Value)

            Me.cmbPicturesName.AddItem (ActSheet.Cells(CRow, CCol).Value)

        End If

    Next CCol

    If Me.cmbImageColumn.ListCount > 0 Then

        Me.cmbImageColumn.ListIndex = 0

        Me.cmbPicturesName.ListIndex = 0

    End If

    

End Sub

 

Private Sub UserForm_Initialize()

    Dim Ws As Worksheet

    Me.cmbSheets.Clear

    For Each Ws In ActiveWorkbook.Worksheets

        Me.cmbSheets.AddItem Ws.Name

    Next

    If Me.cmbSheets.ListCount > 0 Then

        Me.cmbSheets.ListIndex = 0

    End If

End Sub


Please Watch YouTube Video -



Comments

Post a Comment

Popular posts from this blog

Excel VBA To Send Data From Excel Sheet To The Google Sheet

Image
  VBA Code - Option Explicit Private Sub btnSendDataToGoogleSheet_Click()     Dim EmpId As Long, EmpName As String, Address As String, Gender As String, Desi As String     Dim HeaderName As String, SendID As String, Url1 As String, Url2 As String, FinalUrl As String     Dim TicketInfo As ServerXMLHTTP60     Dim TRow As Long, CRow As Long     TRow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row     If TRow < 2 Then Exit Sub     For CRow = 2 To TRow         EmpId = Sheet1.Range("A" & CRow).Value         EmpName = Sheet1.Range("B" & CRow).Value         Address = Sheet1.Range("C" & CRow).Value         Gender = Sheet1.Range("D" & CRow).Value         Desi = Sheet1.Range("E" & CRow).Value         Url1 = "https://docs.google.com/forms/d/e/1FAIpQLSeUUjHkOE3H8YiIGHlmIymzKxsBuPDHN...
Read more

Data Entry Form Connected With Database (Excel Sheet)

Image
VBA Code - Option Explicit Dim curRecNo As Long Private Sub btnFirst_Click()          If Me.cmbEmpName.ListCount > 0 Then              Me.cmbEmpName.ListIndex = 0                  curRecNo = Me.cmbEmpName.ListIndex + 1         Me.lblCurrentRecNo.Caption = "Record No.: " & curRecNo              End If      End Sub Private Sub btnLast_Click()     If Me.cmbEmpName.ListCount > 0 Then              Me.cmbEmpName.ListIndex = Me.cmbEmpName.ListCount - 1                  curRecNo = Me.cmbEmpName.ListCount         Me.lblCurrentRecNo.Caption = "Record No.: " & curRecNo              End If          End Sub Private Sub btnNext_Click()   ...
Read more