Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.

Hi Krieg.
I see that the images are about 8 Mb.
Is that correct?
That's not exactly my intention, the jpg's I make using oDoc.SaveAs(NewImageFileName, True) are no larger than about 400 Kb, which is very handy.

May I ask you the question differently.
How can I get those images, which are already there anyway, in an Excel cell.
I've done some research and tried that, but to no avail.
I manage to get them into the Excel file, but not to the location so that they come in a cell or have the location of a cell.
So they all come together.
I also more or less understood that the images are over it which is fine by the way.

 

This is what I've tried, thereafter more code to see my complete struggle.

This one looks great but I do not know how to get it working:

https://stackoverflow.com/questions/12936646/how-to-insert-a-picture-into-excel-at-a-specified-cell-...

With ExcelApp.oExcelSheet.Pictures.Insert(fileName)
'							    With .ShapeRange
'							        .LockAspectRatio = msoTrue
'							        .Width = 75
'							        .Height = 100
'							    End With
'							    .Left = ExcelApp.oExcelSheet.Cells(j, 20).Left
'							    .Top = ExcelApp.oExcelSheet.Cells(j, 20).Top
'							    .Placement = 1
'							    .PrintObject = True
'							End With

 

'----------------------------------------------------------------------------------------------------
																	' Set an Excel file for the Parts
																	'====================================================================================================
																	' Fill an Excel file
																	' Get the Inventor user name From the Inventor Options
																	myName= ThisApplication.GeneralOptions.UserName
																	
																	' Define the file to create/open																	
																	Dim TEST_BoM_All_Parts As String = sProject_PO_Folder & "TEST_BoM_All_Parts.xlsx"
																	myXLS_File = TEST_BoM_All_Parts
																	
																	'MsgBox(TEST_BoM_All_Parts)	
																	
																	'Get the Inventor user name From the Inventor Options
																	myName= ThisApplication.GeneralOptions.UserName
																	
																	' Define Excel Application object
																	'ExcelApp = CreateObject("Excel.Application")
																	Dim ExcelApp As New Excel.Application 'Create a new Excel Application
																	' Set Excel to run visibly, change to false if you want to run it invisibly
																	'ExcelApp.Visible = True
																	ExcelApp.Visible = False
																	
																	' Suppress prompts (such as the compatibility checker)
																	ExcelApp.DisplayAlerts = False
																	
																	' Check for existing file
																	' Delete file, to avoid error regarding Table
																	If System.IO.File.Exists(myXLS_File) Then System.IO.File.Delete(myXLS_File)
																		
																	Dim oWB
																	If Dir(myXLS_File) <> "" Then
																	' Workbook exists, open it
																	oWB = ExcelApp.Workbooks.Open(myXLS_File)
																	'oExcelSheet = oWB.Worksheets(1)
																	Else
																	' Create a new spreadsheet from template
																	oWB = ExcelApp.Workbooks.Add '(Template: = "C:\Temp\HML_BoM_PO.xlt")
																	End If																	
																						
																						' Insert data into Excel.
																						'With ExcelApp
																						'	.Range("A1").Select
																						'	.ActiveCell.FormulaR1C1 = "Hello, " & myName
																						'End With   
																																					
																						Dim oExcelSheet
																						oExcelSheet = oWB.Worksheets.Item(1)
																						
																						Dim oCells
																						oCells = oExcelSheet.Cells																						
																						
																						' Create column headers
																					    ' First number is Row index, second number is Column Index
																					    oCells.Item(1,  1).Value = "Thumbnail"
																						oCells.Item(1,  2).Value = "QTY"
																					    oCells.Item(1,  3).Value = "Material+Thick+Fabr"
																					    oCells.Item(1,  4).Value = "Part Number"
																						oCells.Item(1,  5).Value = "REV"
																						oCells.Item(1,  6).Value = "Description"
																						oCells.Item(1,  7).Value = "Finishing"
																						oCells.Item(1,  8).Value = "Dimensions" '"Parameters"
																						oCells.Item(1,  9).Value = "Bends"
																						oCells.Item(1, 10).Value = "Tapping"
																						oCells.Item(1, 11).Value = "CSINK"
																						oCells.Item(1, 12).Value = "CBORE"
																						oCells.Item(1, 13).Value = "Under Class Approval"
																						oCells.Item(1, 14).Value = "Mass"																								
																	
																	' Set all of the columns to autofit
																	'ExcelApp.Columns.AutoFit   
																	' Save the file
																	'oWB.SaveAs (myXLS_File)
																	
																	' Close the workbook and the Excel Application
																	' Uncomment if you want to close the xls file at the end
																	'oWB.Close
																	'ExcelApp.Quit
																	'ExcelApp = Nothing'
																	'====================================================================================================
															
															'----------------------------------------------------------------------------------------------------
															sw.WriteLine
															sw.WriteLine
															sw.WriteLine("Parts - " & DictionaryPartsPublish.count & "x")
															sw.WriteLine		
															Dim j As Integer
															For Each pair As KeyValuePair(Of String, Document) In DictionaryPartsPublish
																sw.WriteLine(pair.Key)
																DictionaryAllFilesToBePublished.add(pair.Key, pair.Value)
																DictionaryAllFilesToBePublishedNoQTY.add(Left(pair.Key, InStrRev(pair.Key, "(") -1),Left(pair.Key, InStrRev(pair.Key, "(") -1))
																'IsFileInUse(pair.Key)
															
																		'----------------------------------------------------------------------------------------------------
																		'====================================================================================================
																		' Fill the created Excel file
																		
																						Dim oDoc As Document = pair.Value
																		
																						' Get Properties
																						Dim sPartNumber As String = GetProp(oDoc, "DTP", "Part Number")
																						Dim sRev As String = GetProp(oDoc, "ISI", "Revision Number")
																						Dim sDescription As String = GetProp(oDoc, "DTP", "Description")
																						Dim sMaterial As String = GetProp(oDoc, "DTP", "Material")
																						Dim sThickness As String = GetProp(oDoc, "IUDP", "Thickness")	
																						Dim sFinishing As String  = GetProp(oDoc, "IUDP", "Finishing")
																						Dim sFabrication As String = GetProp(oDoc, "IUDP", "Fabrication")
																						Dim sBends As String = GetProp(oDoc, "IUDP", "Bends")
																						Dim sTAPPING As String = GetProp(oDoc, "IUDP", "TAPPING")
																						Dim sCSINK As String = GetProp(oDoc, "IUDP", "CSINK")
																						Dim sCBORE As String = GetProp(oDoc, "IUDP", "CBORE")
																						Dim sUnderClassApproval As String = GetProp(oDoc, "IUDP", "Under Class Approval")
																						Dim sPartParameters As String = GetProp(oDoc, "IUDP", "PartParameters")
																						Dim sMass As String = GetProp(oDoc, "IUDP", "Mass")
																						Dim sCombinedProductionOutput As String = GetProp(oDoc, "IUDP", "Combined Production Output")
																						
																						sDocType = GetDocumentType_And_SubType(oDoc)
	
																						'Get Fabrication_info Flat, Bend or Unknown					
																						If sFabrication Like "*F*" And sDocType Like "*Sheet_metal*" Then
																							sFabrication_Info = " " & sThickness & " mm Flat"
																						ElseIf sFabrication Like "*B*" And sDocType Like "*Sheet_metal*" Then	
																							sFabrication_Info = " " & sThickness & " mm Bend"
																						Else
																							sFabrication_Info = ""
																						End If
																						
																						' Make 'S', 'Z', Tapping, CSINK and CBORE visible
																						If sTAPPING Like "*Yes*" Or sCSINK Like "*Yes*" Or sCBORE Like "*Yes*" Or sFabrication Like "*S*" Or sFabrication Like "*Z*" Then
																							sFabrication_Info = sFabrication_Info & "+"		
																						End If																		
																						
																						'----------------------------------------------------------------------------------------------------
																						' Add Picture
																																												
																						Dim oThumb As stdole.IPictureDisp
																						Do
																							oThumb = oDoc.Thumbnail
																						Loop While oThumb.Handle<0
																					
																						Dim myPict As New AxHostConverter 
																						Dim oImage As System.Drawing.Image=myPict.GetImageFromIPictureDisp(oThumb)
																						
																						oImage.Save("C:\TEMP\bmptest.bmp",System.Drawing.Imaging.ImageFormat.Bmp)
																						
																						'oCells.Item(j + 2, 1).Value = oImage
																						
																						
																						
																						
																						
																						
																						
																						
																						
																						
																						
																						
																						'Dim tempDoc As Document = pair.Key
																		
''																						' Get the thumbnail image. 
'																						Dim thumbnail As IPictureDisp 'stdole.IPictureDisp 
'																						thumbnail = tempDoc.Thumbnail()
																						
''																						' Convert the IPictureDisp object to an Image. 
'																						'Dim img As Image = Compatibility.VB6.IPictureDispToImage(thumbnail)
																						
'																						'Dim img As Image = pair.Value(thumbnail)
'																						'Document.Thumbnail() As IPictureDisp
'																						'oCells.Item(j + 2, 1).Value = GetProp(pair.Value, "ISI", "Thumbnail")
'																						'oCells.Item(j + 2, 1).Value = img

						' Try to add a picture to Excel
						'xlWorkSheet.Shapes.AddPicture("C:\xl_pic.JPG", Microsoft.Office.Core.MsoTriState.msoFalse, Microsoft.Office.Core.MsoTriState.msoCTrue, 50, 50, 300, 45)
						'r = oExcelSheet.Cells(5, 2)

						'fileName = "C:\Workingfolder\Projecten\149.0389-PO\70\06-Parts-SS\AISI 304+\AISI 304+   A02095-389.ipt-A Bushing rope pulley Øh17 L=32mm(1x).jpg"
						
						'pictureWidth = 195
						'pictureHeight = 102
						
						'shape = oExcelSheet.Shapes.AddPicture(fileName, Microsoft.Office.Core.MsoTriState.msoTrue, Microsoft.Office.Core.MsoTriState.msoTrue, r.Left, r.Top, pictureWidth * 3 / 4, pictureHeight * 3 / 4)
						        'oExcelSheet.Shapes.AddPicture(fileName, Microsoft.Office.Core.MsoTriState.msoTrue, Microsoft.Office.Core.MsoTriState.msoTrue, i + 2, j + 1, 100, 100)
						'shape.LockAspectRatio = msoTrue
						'shape.ScaleHeight 2, msoTrue, msoScaleFromTopLeft
						
						
						Try
						
						'oExcelSheet.Range("a1").Select()
						'oExcelSheet.Rows(j + 2).select
						'oExcelSheet.Columns(1).select
						'oExcelSheet.Pictures.Insert(fileName)

'							With ExcelApp.oExcelSheet.Pictures.Insert(fileName)
'							    With .ShapeRange
'							        .LockAspectRatio = msoTrue
'							        .Width = 75
'							        .Height = 100
'							    End With
'							    .Left = ExcelApp.oExcelSheet.Cells(j, 20).Left
'							    .Top = ExcelApp.oExcelSheet.Cells(j, 20).Top
'							    .Placement = 1
'							    .PrintObject = True
'							End With
							
							
'							With oExcelSheet.Pictures.Insert(fileName:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
'						        With .ShapeRange
'						            .LockAspectRatio = msoTrue
'						            .Width = destRange.Width
'						            .height = destRange.height '222
'						        End With
'						        .Left = destRange.Left
'						        .Top = destRange.Top
'						        .Placement = 1
'						        .PrintObject = True
'						        .Name = imageName
'						    End With
						
'						ActiveSheet.Pictures.Insert(fileName).Select
'						Selection.Top = Target.Offset(0, 2).Top
'						Selection.Left = Target.Offset(0, 3).Left
'						Selection.ShapeRange.LockAspectRatio = msoFalse
'						Selection.ShapeRange.Height = Target.Offset(0, 2).Height
'						Selection.ShapeRange.Width = Target.Offset(0, 3).Width
						
					
					
						Catch ex As IOException
						
							log.Close()
						
						End Try
													
																		
																		' First number is Row index, second number is Column Index
																		oCells.Item(j + 2,  2).Value = GetQTYfromStr(pair.Key)
																		oCells.Item(j + 2,  3).Value = sMaterial & sFabrication_Info
																		oCells.Item(j + 2,  4).Value = sPartNumber
																		oCells.Item(j + 2,  5).Value = sRev
																		oCells.Item(j + 2,  6).Value = sDescription																		
																		oCells.Item(j + 2,  7).Value = sFinishing	
																		oCells.Item(j + 2,  8).Value = sPartParameters
																		oCells.Item(j + 2,  9).Value = sBends
																		oCells.Item(j + 2, 10).Value = sTAPPING
																		oCells.Item(j + 2, 11).Value = sCSINK
																		oCells.Item(j + 2, 12).Value = sCBORE
																		oCells.Item(j + 2, 13).Value = sUnderClassApproval
																		oCells.Item(j + 2, 14).Value = sMass
																	
															
																		'====================================================================================================
															j = j + 1
															Next
															
																		'----------------------------------------------------------------------------------------------------
																		' Arrange Rows and Columns
																		' Those next lines seems to work																		
																		
																				' Get Last Row and Last Column as numbers
																				With oExcelSheet
																			    	If ExcelApp.WorksheetFunction.CountA(.Cells) <> 0 Then
																			        	lRow = .Cells.Find(What:="*", _
																			                      After:=.Range("A1"), _
																			                      LookAt:=Excel.XlLookAt.xlPart, _
																			                      LookIn:=Excel.XlFindLookIn.xlFormulas, _
																			                      SearchOrder:=Excel.XlSearchOrder.xlByRows, _
																			                      SearchDirection:=Excel.XlSearchDirection.xlPrevious, _
																			                      MatchCase:=False).Row
																				    Else
																				        lRow = 1
																				    End If
																				End With
																				
																				With oExcelSheet
																			    	If ExcelApp.WorksheetFunction.CountA(.Cells) <> 0 Then
																			        	lCol = .Cells.Find(What:="*", _
																			                      After:=.Range("A1"), _
																			                      LookAt:=Excel.XlLookAt.xlPart, _
																			                      LookIn:=Excel.XlFindLookIn.xlFormulas, _
																			                      SearchOrder:=Excel.XlSearchOrder.xlByColumns, _
																			                      SearchDirection:=Excel.XlSearchDirection.xlPrevious, _
																			                      MatchCase:=False).Column
																				    Else
																				        lCol = 1
																				    End If
																				End With
																				
'																				'MessageBox.Show("LRow: " & LRow & vbNewLine & "LCol: " & LCol)
																		
'																		' Filter BOM for Normal or Purchased BOM_structure files
'																		'Filter(oExcelSheet, Normal, lrRow)		
																				
'																    	' This resizes the selection  but, I don't really know what for...
'																		Dim rng As Excel.Range
'																    	'rng = ExcelApp.Cells(1, 1).Resize(lRow, lCol)
'																		'rng = oExcelSheet.Cells(1, 1).Resize(lRow, lCol)
																		
'																		' Create Table
																		oExcelSheet.ListObjects.Add()		
																    	oExcelSheet.ListObjects(1).Name = "Table"
																		
'																		' Set Table Style based on BoM Type
'																		' HML Table Style :
'																		' - Structured All Levels		- Orange 		- TableStyleLight10
'																		' - Structural Single Level		- Black/White	- TableStyleLight15
'																		' - Parts Only Normal			- Yellow 		- TableStyleLight10
'																		' - Purchased					- Blue			- TableStyleLight12		
																		
'																		'If BoMExporter = "Structured - All Levels" Then :oExcelSheet.ListObjects(1).TableStyle = "TableStyleLight10" : End If
'																		'If BoMExporter = "Structured - Single Level" Then :oExcelSheet.ListObjects(1).TableStyle = "TableStyleLight15" : End If
'																		'If BoMExporter = "Parts Only - (Shows components in a flat list)" Then : oExcelSheet.ListObjects(1).TableStyle = "TableStyleLight12" : End If
																		oExcelSheet.ListObjects(1).TableStyle = "TableStyleLight12"
																		
'																		' If BoMExporter = "Purchased" Then : oExcelSheet.ListObjects(1).TableStyle = "TableStyleLight13" : End If 
																		
																		
'																		'**************************************************************************************
'																		' Help
'																		' xlCenter is a member of Microsoft.Office.Interop.Excel.Constants.
'																		' Since you assigned Microsoft.Office.Interop.Excel To the name Excel, you can reference that constant Like this...
'																		' oExcelSheet.Range("H15:H16").VerticalAlignment = Excel.Constants.xlCenter
'																		'**************************************************************************************
																					
																		'Freeze Header and Column
																		FreezeHeader(oExcelSheet, 1, 7)
																		'FreezeHeader(oExcelSheet, 1, 2)
																		
																		' Autofit all Columns except the 1st one with pictures
																		oExcelSheet.Columns("B:" & GetExcelColumnName(LCol)).EntireColumn.AutoFit
																		'ExcelApp.Columns.AutoFit
																		
																		' Center Columns Horizontaly
																		HorizontalAlignment_xlCenter(oExcelSheet, lCol, "QTY")
																		HorizontalAlignment_xlCenter(oExcelSheet, lCol, "REV")
																		HorizontalAlignment_xlCenter(oExcelSheet, lCol, "Fabrication")
																		HorizontalAlignment_xlCenter(oExcelSheet, lCol, "Bends")
																		HorizontalAlignment_xlCenter(oExcelSheet, lCol, "Tapping")
																		HorizontalAlignment_xlCenter(oExcelSheet, lCol, "CSINK")
																		HorizontalAlignment_xlCenter(oExcelSheet, lCol, "CBORE")
																		HorizontalAlignment_xlCenter(oExcelSheet, lCol, "Under Class Approval")																		
																		
'																		' Delete Columns
'																		'DeleteColumn(oExcelSheet, lCol, "BOM Structure")
'																		'DeleteColumn(oExcelSheet, lCol, "Stock Number")
'																		'DeleteColumn(oExcelSheet, lCol, "Spare part")
'																		'DeleteColumn(oExcelSheet, lCol, "Oem part number")
'																		'DeleteColumn(oExcelSheet, lCol, "Maintenance")
'																		'DeleteColumn(oExcelSheet, lCol, "Manufacturer")
'																		'DeleteColumn(oExcelSheet, lCol, "Vendor")
'																		'DeleteColumn(oExcelSheet, lCol, "Project")
'																		'DeleteColumn(oExcelSheet, lCol, "Filename")
																		
																		'oExcelSheet.Columns(1).ColumnWidth = 19
																		oExcelSheet.Rows.RowHeight = 68.25
																		oExcelSheet.Rows(1).RowHeight = 15
																		
'																		' Untill here above lines seems to work		
																		
																		'====================================================================================================
																		' Set all of the columns to autofit
																		'ExcelApp.Columns.AutoFit   
																		' Save the file
																		oWB.SaveAs (myXLS_File)
																		
																		' Close the workbook and the Excel Application
																		' Uncomment if you want to close the xls file at the end
																		oWB.Close
																		ExcelApp.Quit
																		ExcelApp = Nothing'
																		'====================================================================================================