Hi. Code given below.
Sub Convert()
' Created by Naveen Siddula - 22-Feb-2021
' CONVERTING IMAGE IN C COLUMN OF A CSV FILE
Dim xFd As FileDialog
Dim xSPath As String
Dim xCSVFile As String
Dim xWsheet As String
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = False
Application.StatusBar = True
xWsheet = ActiveWorkbook.Name
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.Title = "Select a folder:"
If xFd.Show = -1 Then
xSPath = xFd.SelectedItems(1)
Else
Exit Sub
End If
If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
xCSVFile = Dir(xSPath & "*.csv")
Do While xCSVFile <> ""
Application.StatusBar = "Converting: " & xCSVFile
Workbooks.Open Filename:=xSPath & xCSVFile
Cells.Select
Cells.EntireColumn.AutoFit
Columns("C:C").Select
Selection.ColumnWidth = 129.86
Selection.RowHeight = 30
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.AskToUpdateLinks = False
'Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("C2:C10000")
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
.Width = 60
.Height = 30
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
Application.DisplayAlerts = True
End With
lab:
Set Pshp = Nothing
Range("A2").Select
Next
'ALIGINING IMAGE AND MOVING LEFT
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
ActiveSheet.Shapes.SelectAll
Selection.Placement = xlMoveAndSize
Application.CommandBars("Format Object").Visible = False
Columns("C:C").Select
Selection.ClearContents
ActiveSheet.Shapes.Range(Array("Picture 2")).Select
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.IncrementLeft -308.25
Selection.ShapeRange.IncrementTop -0.75
Selection.ColumnWidth = 15
Columns("C:C").ColumnWidth = 13
Range("C1").Select
ActiveCell.FormulaR1C1 = "Image"
Range("C2").Select
ActiveSheet.Shapes.Range(Array("Picture 2")).Select
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.IncrementTop 0.75
Selection.ShapeRange.IncrementTop 0.75
Selection.ShapeRange.IncrementTop 0.75
ActiveWorkbook.SaveAs Replace(xSPath & xCSVFile, ".csv", ".xlsx", vbTextCompare), xlWorkbookDefault
ActiveWorkbook.Close
Windows(xWsheet).Activate
xCSVFile = Dir
Loop
Application.StatusBar = False
Application.DisplayAlerts = True
Application.AlertBeforeOverwriting = False
Application.ScreenUpdating = False
MsgBox "COMPLETED"
End Sub
Bookmarks