please guide me how to resize or stretch the picture with in a cell using vb 6.0
vanathi_vb 0 Newbie Poster
manoshailu 12 Junior Poster
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:
vanathi_vb 0 Newbie Poster
Thank you shailu.. its working fine..its very helpful ..
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:
GKitto 0 Newbie Poster
Shalaja,
Quick question. I need to use this, but am a newby on VB. I've opened the editor and have made the code pane visible. Do I simply paste this code there and save the macro-enabled spreadsheet? I've done this, but see nothing on the sheet.
Any further help is greatly appreciated!
Glen
samivel 0 Newbie Poster
please guide how to insert a picture in a particular excel cell using vb6 coding
manoshailu 12 Junior Poster
please guide how to insert a picture in a particular excel cell using vb6 coding
Hi,
Follow the steps to get the image in excel:
1. Open the Visual Basic 6.0.
2. Create new project.
3. Go to design window and draw the command button and common dialog control.
4. In the code window, Paste the code which is in this forum.
5. Run the project.
6. Click the command button.
7. It will request for image file so select the image from the open dialog box.
8. Then again request for File name to save.
9. Finally it request for cell name or position to place the image.
10. Enter the required values and click ok.
11. At the end of the process, u will get the msg as "Exported to Excel File
Succesfully."
12. Then open the file to check.
If u have any queries, u can ask me.
Shailaja:cool:
Be a part of the DaniWeb community
We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.