Consulting

Results 1 to 11 of 11

Thread: Solved: Help: Need to export image from Excel

  1. #1
    VBAX Regular
    Joined
    Jan 2007
    Posts
    9
    Location

    Solved: Help: Need to export image from Excel

    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:

    [VBA] 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
    .
    .[/VBA]
    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.


    Thanks in advance for any help.
    Ivan

  2. #2
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    This will help you find every shape on a sheet. Replace the code to delete with your code.
    [VBA]Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
    Shp.Delete
    Next[/VBA]
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  3. #3
    VBAX Regular
    Joined
    Jan 2007
    Posts
    9
    Location
    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.....

  4. #4
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    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.
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  5. #5
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    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.
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  6. #6
    Administrator
    2nd VP-Knowledge Base
    VBAX Master malik641's Avatar
    Joined
    Jul 2005
    Location
    Florida baby!
    Posts
    1,533
    Location
    Subscribing I'd like to see this too.

    So far, all I got is:
    [VBA]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[/VBA]

    But for now, I'm going to sleep




    New to the forum? Check out our Introductions section to get to know some of the members here. Feel free to tell us a little about yourself as well.

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

    Search MSDN for much of this code...
    [VBA]
    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
    [/VBA]

    Example usage:
    Sheet1 must contain the objectd listed in the procedure below in order for the code to succeed...
    [VBA]
    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
    [/VBA]

  8. #8
    VBAX Regular
    Joined
    Jan 2007
    Posts
    9
    Location

    Thumbs up RESOLVED

    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, LUCAS, Malik641 and TsTOM.....


    Thanks to you.
    Ivan

  9. #9
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Your welcome Ivan......glad you found your solution.
    Joeseph and TSTom deserve most of the credit
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  10. #10
    Administrator
    2nd VP-Knowledge Base VBAX Master malik641's Avatar
    Joined
    Jul 2005
    Location
    Florida baby!
    Posts
    1,533
    Location
    No problem Ivan! Happy to help

    tstom's code is awesome Nice work!




    New to the forum? Check out our Introductions section to get to know some of the members here. Feel free to tell us a little about yourself as well.

  11. #11
    Administrator
    Chat VP VBAX Guru johnske's Avatar
    Joined
    Jul 2004
    Location
    Townsville, Australia
    Posts
    2,872
    Location
    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.
    [VBA]
    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
    [/VBA]
    You know you're really in trouble when the light at the end of the tunnel turns out to be the headlight of a train hurtling towards you

    The major part of getting the right answer lies in asking the right question...


    Made your code more readable, use VBA tags (this automatically inserts [vba] at the start of your code, and [/vba ] at the end of your code) | Help those helping you by marking your thread solved when it is.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •