VBA - Extract Pictures from Excel

Last month, I have written Excel Automation Using VBScript. Today this post is to extract Pictures from Excel. Generally We can not use Export method for pictures. But we can use for Excel charts. I tried to extract our SVG chart image by macro and I succeed on it. I got help from Export pictures from Excel Below I've given the VBA Macro code.

VBA Macro - To extract Picture from Excel

Sub GetFirstPicture()

Dim sCurrPath As String
Dim aWorkSheet As Excel.Worksheet
Dim aShape As Excel.Shape
Dim aShapeChart As Excel.Shape
Dim aPicture As Variant
Dim aChart As Excel.Chart
Dim sCurrentSheet As String

Dim aImage As Variant
Dim iIndex As Integer
Dim iShapeCount As Integer

Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Dim sChartJpg As String
Dim sChartGif As String
Dim sChartBmp As String

'On Error GoTo ErrHandler
On Error Resume Next

Application.ScreenUpdating = False

sCurrPath = "D:\VB\MyTrials\ChartExpFromXL"
sChartJpg = "D:\VB\MyTrials\ChartExpFromXL.jpg"
sChartGif = "D:\VB\MyTrials\ChartExpFromXL.gif"
sChartBmp = "D:\VB\MyTrials\ChartExpFromXL.bmp"

Set aWorkSheet = ActiveWorkbook.ActiveSheet
sCurrentSheet = aWorkSheet.Name

'MsgBox CStr(msoTrue) + " value for MsoTrue"
' MsoTrue equals to -1
MsgBox "Shapes count " + CStr(aWorkSheet.Shapes.Count)
For iIndex = 1 To aWorkSheet.Shapes.Count

Set aShape = aWorkSheet.Shapes(iIndex)
MyPicture = aShape.Name
MsgBox aShape.Name + " Name, " + Str(aShape.Type)
'Picture 1 Name,  13
If Left(aShape.Name, 7) = "Picture" Then
With aShape
PicHeight = .Height
PicWidth = .Width
End With
'Set aChart = aWorkSheet.ChartObjects(1)
Set aChart = ActiveWorkbook.Charts.Add
ActiveWorkbook.ActiveChart.Location Where:=xlLocationAsObject, Name:=sCurrentSheet
iShapeCount = aWorkSheet.Shapes.Count
Set aShapeChart = aWorkSheet.Shapes(iShapeCount)
MyChart = aShapeChart.Name      '"Chart " & Str(aWorkSheet.Shapes.Count)

aShapeChart.Width = PicWidth
aShapeChart.Height = PicHeight


With aWorkSheet
aShape.Copy

With ActiveChart 'aChart
.ChartArea.Select
.Paste
End With

.ChartObjects(1).Chart.Export Filename:=sChartJpg, FilterName:="jpg", Interactive:=True
.ChartObjects(1).Chart.Export Filename:=sChartGif
.ChartObjects(1).Chart.Export Filename:=sCurrPath & ".png"
'Not working .ChartObjects(1).Chart.Export Filename:=sChartBmp, FilterName:="bmp"
aShapeChart.Cut
End With

Application.ScreenUpdating = True

MsgBox "Completed."
Exit Sub

End If

Next

MsgBox "Completed."
Exit Sub

ErrHandler:
MsgBox "Error # " & CStr(Err.Number) & " " & Err.Description & " " & Err.Source
Err.Clear   ' Clear the error.
End Sub

VisualTest - Using Excel Application

Our Automation suite results were in text files. I wanted to create the excel file as results file. You can get to know more about Results Reporting. I used Excel VBA for this. It has simplified my task to prepare the compiled results for entire execution.

Similarly I will write, how to do the same thing by using VB script later....

Code: To check Excel availability in the system

 
'--------------------------------------
' Method : IsExcelAvailable
' Author : T.Palani Selvam
' Purpose :   Checks whether excel application is available or not.
' Parameters: - Nil
' Returns :   Returns integer, whether true or false.
' Caller : 
' Calls  : 
'--------------------------------
Function IsExcelAvailable() As Integer
Dim objExcelApp As Variant

ON LOCAL ERROR GOTO Errhandler

 IsExcelAvailable = False
 objExcelApp = OleCreateObject("Excel.Application")
 Sleep 0.5
 OleReleaseObject(objExcelApp)
 IsExcelAvailable = True
 Exit Function

ErrHandler:
   'LogWrite("[Failed At] " + ERF(0)+ "("+ str(ERL) +") :  "+ ERROR$ + " .Error Number: " + str(Err),1)   'Actual location.
   'Logwrite("[Trapped At] "+ ERF(1)+ "("+ str(ERL(1))+ ")",1)   'Trapped location.
  Logwrite("Excel Application is not available.", 2)
End Function

Code: To Read Excel data

 
'---------------------------------------
' Method : ReadExcelCells
' Author : T.Palani Selvam
' Purpose :   Read the content from given Excel file
'  and checks result automatically, while completing a test case.
' Parameters: - Nil -
' Returns :   - Nil -
' Caller : 
' Calls  : 
'
'--------------------------------------
Function ReadExcelCells(sExcelFile as String, sWorkBook as String,sWorkSheet as String,sArrFields() As String) As Integer
DIM objExcelApp As Variant,objExcel As Variant, objCurrentCell As Variant
DIM objWorkBook As Variant,objWorkSheet As Variant

Dim iRows As Integer, iCols As Integer
Dim iRowStatus As Integer, iColStatus As Integer
Dim iRowIndex As integer, iColIndex As integer, iIndex As Integer
Dim sCellValue As String, sValue as String

  ReadExcelCells = False

 objExcel = OleGetObject (sExcelFile)
 objExcelApp = OleDispatch (objExcel,"Application")
 'objExcelApp = OleCreateObject ("Excel.Application")
 objWorkBook = OleDispatch (objExcelApp,"Workbooks", sWorkBook)
 'objWorkBook = OleDispatch (objExcelApp,"Workbooks")
 'OleDispatch(objWorkBook,"Add",sWorkBook)
 objWorkSheet= OleDispatch (objWorkBook,"Sheets", sWorkSheet)

 iIndex = 1
 Do While Not (iRowStatus)
  objCurrentCell= OleDispatch (objWorkSheet, "Cells", iIndex, 1)
  sValue = OleGetProperty (objCurrentCell, "Value")
  If (Len(Trim(sValue)) = 0 ) Then
   iRowStatus = True
  End IF
  iIndex = iIndex + 1
 Loop
 iRows = iIndex - 2  'Rows Count
 print "No of rows.." + str(iRows)

 iIndex = 1
 Do While Not (iColStatus)
  objCurrentCell= OleDispatch (objWorkSheet, "Cells", 1, iIndex)
  sValue = OleGetProperty (objCurrentCell, "Value")
  If (Len(Trim(sValue)) = 0 ) Then
   iColStatus = True
  End IF
  iIndex = iIndex + 1
 Loop
 iCols = iIndex - 2   'Rows Count
 print "No of Columns.." + str(iCols)

ReDim sArrFields(iCols - 1,1) As String
 For iIndex=1 To iCols
  objCurrentCell= OleDispatch (objWorkSheet, "Cells", 1, iIndex)
  sValue = OleGetProperty (objCurrentCell, "Value")
  sArrFields(iIndex-1, 0) = sValue
 Next iIndex


 For iRowIndex = 2 To iRows 
  For iColIndex = 1 To iCols
   objCurrentCell= OleDispatch (objWorkSheet, "Cells", iRowIndex, iColIndex)
   sValue = OleGetProperty (objCurrentCell, "Value")
   sArrFields(iColIndex-1, 1) = sValue
  Next iColIndex 
  For iIndex = LBOUND(sArrFields,1) TO UBOUND(sArrFields,1)
   Print "Field (Name,Value): " + sArrFields(iIndex, 0),sArrFields(iIndex, 1)
   'Print "Field Value: " + sArrFields(iIndex, 1)
  Next iIndex
 Next iRowIndex 

 OleReleaseObject (objWorkSheet)
 OleReleaseObject (objWorkBook)
 OleReleaseObject (objExcelApp)
 OleReleaseObject (objExcel)
 
 ReadExcelCells = True
End Function

Code: To set Test Results by different colors

 
'-------------------------------------------------------------------------
' Method : setResultXLDetails
' Author : T.Palani Selvam
' Purpose :   Set the standard format for the given Cell Object.
' Parameters: sDetails - String, contains information to be written into Excel cell object
'   lRow - Long, contains row number
'   lCol - long, contains Column number
'   iFontType As Integer
'   iFontColor As Integer
' Returns :   -Nil
' Caller : 
' Calls  : 
'-------------------------------------------------------------------------
'Default values will be given iFontType =0, iFontColor =0
Sub setResultXLDetails(sDetails As String, lRow As Long, lCol As Long,iFontType As Integer, iFontColor As Integer)
Dim objCell As Variant, objFont As Variant

 If Not IsNull(gObjWorkBook)  Then
  objCell = OleDispatch(gObjWorkSheet,"Cells",lRow,lCol)
  objFont = OleDispatch(objCell, "Font")
  Select Case iFontType
   Case 1    
    OleSetProperty(objFont,"Bold",True)    
   Case 2    
    OleSetProperty(objFont,"Italic",True)    
   Case 3           
    OleSetProperty(objFont,"Bold",True)
    OleSetProperty(objFont,"Italic",True)    
   Case Else
  End Select
 
  Select Case iFontColor
   Case Is < 1
   Case Is < 26
    OleSetProperty(objFont,"ColorIndex",iFontColor)
   Case Else
  End Select
  
  OleSetProperty(objCell,"Value", sDetails)
  OleReleaseObject(objFont)
  OleReleaseObject(objCell)
 End IF
End Sub

Code: To set value into given cell

 
'-------------------------------------------------------------------------
' Method : setResultDetails
' Author : T.Palani Selvam
' Purpose :   Set the standard format for the given Cell Object.
' Parameters: sDetails - String, contains information to be written into Excel cell object
'   lRow - Long, contains row number
'   lCol - long, contains Column number
' Returns :   -Nil
' Caller : 
' Calls  : 
'-------------------------------------------------------------------------
Sub setResultDetails(sDetails As String, lRow As Long, lCol As Long)
Dim objCell As Variant
 If Not IsNull(gObjWorkBook)  Then
  objCell = OleDispatch(gObjWorkSheet,"Cells",lRow,lCol)
  OleSetProperty(objCell,"Value", sDetails)
  OleReleaseObject(objCell)
 End IF
End Sub