Hi vanathi,
Try the below coding
Private Sub Command1_Click()
On Error GoTo ErrTrap
'DECLARE VARIABLES
Dim xApp As Object
Dim xWb As Object
Dim xWs As Object
Dim strFileName
Dim st As String
Dim ed As String
Dim rw As Integer
Dim ct As String
Dim img As String
Dim xRow As Object
Dim CurRange As Object
Dim img1 As Image
Dim h As Long
Dim w As Long
'TO CREATE A NEW EXCEL APPLICATION
Set xApp = CreateObject("Excel.Application")
'USE COMMONDIALOG CONTROL TO SELECT THE PICTURE AND TO SAVE THE FILE
With CommonDialog1
'TO SELECT THE PICTURE
.ShowOpen
img = .FileName
Picture1.Picture = LoadPicture(img)
'TO SAVE THE FILE
.Filter = UCase("Excel Sheet (*.xls) |*.xls|All Files (*.*)| *.*")
.CancelError = True
.ShowSave
strFileName = .FileName
End With
Screen.MousePointer = vbHourglass
With Ctl
'TO ADD WORKBOOKS AND WORKSHEETS
xApp.Workbooks.Add
Set xWb = xApp.Workbooks(1)
Set xWs = xWb.Worksheets(1)
'ASSIGN THE HEIGHT AND WIDHT TO THE VARIABLE h = Picture1.Image.Height
w = Picture1.Image.Width
'GET THE POSITION OF THE CELL
st = InputBox("Enter the Start Position")
rw = InputBox("Enter the row")
cl = st & ":" & st
rw1 = rw & ":" & rw
ct = st & rw & ":" & st & rw
'ASSIGN THE COLUMN AND WIDTH OF THE CELL
xWs.Columns(cl).ColumnWidth = IIf(w > 1000, (w / 1000) * 30, (w / 1000) * 7)
xWs.Rows(rw1).RowHeight = IIf(h > 1000, 100, (h / 1000) * 37)
xWs.Range(ct).Select
'INSERT IMAGE INTO THE EXCEL FILE
xApp.ActiveSheet.Pictures.Insert(img).Select
End With
'SAVE FILE xWb.SaveAs strFileName
xWb.Close
xApp.Quit
Set xWb = Nothing
Set xApp = Nothing
Screen.MousePointer = vbDefault
MsgBox "Exported to Excel File Succesfully.", vbInformation, App.ProductName
Exit Sub
ErrTrap:
Screen.MousePointer = vbDefault
If Err.Number = 1004 Then
'MsgBox "The Given File Name is Already Opened." & vbCrLf & "Please Close the File and then Export it to Overwrite." & vbCrLf & "---Check Whether an Template File named" & App.Path & " ':\ExportToExcel.XLS' Is there in C:\", vbInformation
MsgBox "The Given File Name is Already Opened." & vbCrLf & "Please Close the File and then Export it to Overwrite.", vbInformation
'''' MsgPanel "Ready"
Exit Sub
End If
If Err.Number <> 32755 Then MsgBox Err.Description, vbInformation, App.ProductName
'''' MsgPanel "Ready"
Exit Sub
Resume
End SubShailaja :icon_lol:
