Solved: Help: Need to export image from Excel

[Matrox]

Hello,
I?m newbie at VBa and I don?t know how to export images that I see in a worksheet and put in a Path as c:\temp\<worksheet>\imageXX.gif due
I don't know what cell there are and what their number.

My VBA Code gettind datas from that worksheet:

Option Compare Database
Private Const ctPathXLS = "C:\temp\"
Private oWorkbook As Excel.Workbook
Private oDb As Database
Private Sub ImportaResumoHorario()
Dim oFileSystem As Scripting.FileSystemObject
Dim oDir As Scripting.Folder
Dim oFile As Scripting.File
Dim oExcel As Excel.Application
Dim oWorksheet As Worksheet
Dim strComando As String
Set oDb = CurrentDb
oDb.Execute ("delete from <My data base>)
Set oExcel = New Excel.Application
Set oFileSystem = New Scripting.FileSystemObject
Set oDir = oFileSystem.GetFolder(ctPathXLS)
Set oFileSystem = Nothing
For Each oFile In oDir.Files
If oFile.Type = "Microsoft Excel Worksheet" Or oFile.Type = "Planilha do Microsoft Excel" Then
Set oWorkbook = oExcel.Workbooks.Open(ctPathXLS & oFile.Name, False, True)
Set oWorksheet = oWorkbook.Worksheets("fl1")
With oWorksheet
.Activate
strA = Right(.Range("E7").Value, 3)
strB = .Range("L7").Value
strC = .Range("T7").Value
strD = .Range("AB7").Value
.
.
Till now everything works fine, even recording at my data base, but
I need now get all images (I see the names Imagem 19,Imagem 20 and so on) from a worksheet and put in a Path as mentioned above.:banghead:


:help :help Thanks in advance for any help.
Ivan

[lucas]

This will help you find every shape on a sheet. Replace the code to delete with your code.
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
Shp.Delete
Next

[Matrox]

Hi Lucas,

Thanks for your help, but as you can see I don?t hv too much experience to go on after the code you said about shapes. Trying to read and learn but no time for that now. Can you help me with that code?
- Find a frist shape
- give a name. gif
- copy that shape to a path c : \ mydir\<worksheet>\name.gif
- next shape

Thanks a lot Lucas.....

[lucas]

While doing a little research on this question I found a thread that addresses this problem. Andy Pope has an addin available for exporting pictures from excel:
http://www.andypope.info/vba/gex.htm

Let me know if you find it useful. Sounds like exactly what your looking for.

[lucas]

Ivan has indicated in a pm that he would like to incorporate code into his app instead of using the addin so if anyone has any ideas I'm sure he would appreciate it.

[malik641]

Subscribing :) I'd like to see this too.

So far, all I got is:
Public Sub ExportPics()
' This iterates through all shapes looking for pictures
' and exports them to a new file
Const strExportPath As String = "C:\TestFolder\"
Dim shp As Excel.Shape

For Each shp In ActiveSheet.Shapes
If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then
Debug.Print shp.Name, shp.Type, "yes"
Else
Debug.Print shp.Name, shp.Type, "no"
End If
Next
End Sub

But for now, I'm going to sleep :cloud9:

[tstom]

Objects that this code can save as a file.
Charts
ChartObjects
OleObjects
Ranges
Shapes
Images (Pictures)

Search MSDN for much of this code...

Option Explicit

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Function PictureFromObject(Target As Object) As IPictureDisp
Dim hPtr As Long, PicType As Long, hCopy As Long

Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
Target.CopyPicture
PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE)
If IsClipboardFormatAvailable(PicType) <> 0 Then
If OpenClipboard(0) > 0 Then
hPtr = GetClipboardData(PicType)
If PicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
CloseClipboard
If hPtr <> 0 Then
Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp

With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With

With uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = hCopy
End With

OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set PictureFromObject = IPic
End If
End If
End If
End Function


Example usage:
Sheet1 must contain the objectd listed in the procedure below in order for the code to succeed...

Sub Example()
'save an image or shape
SavePicture PictureFromObject(Sheet1.Pictures("Picture 1")), "C:\Picture 1.bmp"
'save a shape
SavePicture PictureFromObject(Sheet1.Shapes("WordArt 1")), "C:\WordArt 1.gif"
'save a range
SavePicture PictureFromObject(Sheet1.Range("A1:B4")), "C:\RangeA1_B4.jpg"
End Sub

[Matrox]

I would like to thanks this forum for helped me to understand a little bit about VBA and thanks twice to this guys that posted your ideas about my question, :thumb LUCAS, :thumb Malik641 and :thumb TsTOM.....


Thanks to you.
Ivan

[lucas]

Your welcome Ivan......glad you found your solution.
Joeseph and TSTom deserve most of the credit

[malik641]

No problem Ivan! Happy to help :thumb

tstom's code is awesome :) Nice work!

[johnske]

You can also do this without APIs, but you need to copy the picture, paste it onto a chart and export the chart as a picture. Here's a basic E.G.

Option Explicit

Sub ExportMyPicture()

Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long

Application.ScreenUpdating = False
On Error GoTo Finish
MyPicture = Selection.Name
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With

Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet3"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)

With ActiveSheet
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With

.Shapes(MyPicture).Copy

With ActiveChart
.ChartArea.Select
.Paste
End With

.ChartObjects(1).Chart.Export FileName:="MyPic.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With

Application.ScreenUpdating = True
Exit Sub

Finish:
MsgBox "You must select a picture"
End Sub