[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 896
  • Last Modified:

I need to extract photos from excel to a jpg file and simultaneously to take the alternative image text of the photo and save the jpg filename as the alt text.

i have xlsx . Files with rows with 1 small photo in every row and some product_iD price ... and all the photos have alternative text attribute as the product_code , the photos are placed in the cell of every row not as external link.
I need to extract from excel 2007 xlsx the photos from every row and simultaneously grab the alternative text of the photo (which is the product_ID) and make the photos to individual files with filename as the alternative text . And to do it batch- multiply in 1000 photos.
 xls sample
0
rodojohn
Asked:
rodojohn
  • 4
  • 2
1 Solution
 
rodojohnAuthor Commented:
Hi from Greece

some explanation

The fields in the photo  are photos/  internet_code or product code / logistic code / manufacture / greek description / english  description / availability / category-subcategory /
In the photos detailed  info there is an attribute called alternative text (for the web)  so i need to grab the alt text and give with this the filename of the photo that i have allready extracted .
thanks
0
 
zorvek (Kevin Jones)ConsultantCommented:
Put this code in the worksheet code module, change the constants as desired for your setup, and run the macro.

To add VBA code to a worksheet or chart code module in an Excel workbook, right-click on the worksheet or chart tab at the bottom of the window and select View Code. Paste the code into the document window that appears. Press ALT+F11 to return to the Excel workbook. To find a worksheet or chart module when already in the VBE, press CTRL+R to open the VBE project explorer. Find the module in which the code will be placed - each worksheet and chart module is pre-assigned a name such as "Sheet1 (Sheet1)" where the name inside the parenthesis is the tab name. Double-click the desired module and paste the code into the document window that appears. Press ALT+F11 to return to the Excel workbook.

Public Sub SaveImages()

    Dim FileNumber As Long
    Dim FileData As String
    Dim RegExp As Object
    Dim Matches As Object
    Dim Index As Long

    Const SaveAsLocation = "C:\Documents and Settings\Your Name\Desktop\"
    Const FileName = "Temp.htm"
    Const FolderName = "Temp_files"
    Const ImagesFolderName = "Images"
   
    On Error Resume Next
    Kill SaveAsLocation & FileName
    CreateObject("Scripting.FileSystemObject").GetFolder(SaveAsLocation & FolderName).Delete
    CreateObject("Scripting.FileSystemObject").GetFolder(SaveAsLocation & ImagesFolderName).Delete
    On Error GoTo 0
   
    Me.Copy
    ActiveWorkbook.SaveAs SaveAsLocation & FileName, FileFormat:=xlHtml
    ActiveWorkbook.Close False

    FileNumber = FreeFile
    Open SaveAsLocation & FileName For Binary Access Read As FileNumber
    FileData = StrConv(InputB(LOF(FileNumber), FileNumber), vbUnicode)
    Close FileNumber
   
    Set RegExp = CreateObject("vbscript.regexp")
    RegExp.Global = True
    RegExp.MultiLine = True
    RegExp.IgnoreCase = True
   
    RegExp.Pattern = "src=""([^""]+)""\s+alt=""{0,1}([^""]+)""{0,1} v.shapes="""
   
    On Error Resume Next
    Set Matches = RegExp.Execute(FileData)
    On Error GoTo 0
    If Matches Is Nothing Then Exit Sub
    If Matches.Count = 0 Then Exit Sub
   
    MkDir SaveAsLocation & ImagesFolderName
    For Index = 0 To Matches.Count - 1
        FileCopy SaveAsLocation & Replace(Matches(Index).SubMatches(0), "/", "\"), SaveAsLocation & ImagesFolderName & "\" & Matches(Index).SubMatches(1) & Mid(Matches(Index).SubMatches(0), InStrRev(Matches(Index).SubMatches(0), "."))
    Next Index

    On Error Resume Next
    Kill SaveAsLocation & FileName
    CreateObject("Scripting.FileSystemObject").GetFolder(SaveAsLocation & FolderName).Delete
    On Error GoTo 0

End Sub

Kevin
0
 
rodojohnAuthor Commented:
i run the macro and for the 1st part worked very well
 it created for every image 1 file .PNG and 1 file .GIF   but the gif has corruption (view 1st attachment)
the 2nd is png and is good (view 2nd attachment).
the 2nd part to rename all saved images with filename taken from  the alternative text of the image the makro didnt maked , do you have any suggestion. corruption in the borders good
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
rodojohnAuthor Commented:
i send a demo xlsx , thanks
test.xlsx
0
 
zorvek (Kevin Jones)ConsultantCommented:
This should work. Same instructions.

Public Sub SaveImages()

' Save the images on the active worksheet to separate files.

    Dim TargetFolder As String
    Dim TargetImagesFolder As String
    Dim TargetHTMLFile As String
    Dim TargetHTMLSheetFile As String
    Dim TargetHTMLFolder As String
    Dim FileNumber As Long
    Dim FileData As String
    Dim RegExp As Object
    Dim Matches As Object
    Dim Index As Long
   
    ' Save the images in a new folder "Images" on the desktop
    TargetFolder = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    TargetImagesFolder = TargetFolder & "\Images"
    TargetHTMLFile = TargetImagesFolder & "\Temp.htm"
    TargetHTMLSheetFile = TargetImagesFolder & "\Temp_files\sheet001.htm"
    TargetHTMLFolder = TargetImagesFolder & "\Temp_files"
   
    On Error Resume Next
    CreateObject("Scripting.FileSystemObject").GetFolder(TargetImagesFolder).Delete
    On Error GoTo 0
    MkDir TargetImagesFolder
   
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs TargetHTMLFile, FileFormat:=xlHtml
    ActiveWorkbook.Close False
   
    FileNumber = FreeFile
    Open TargetHTMLSheetFile For Binary Access Read As FileNumber
    FileData = StrConv(InputB(LOF(FileNumber), FileNumber), vbUnicode)
    Close FileNumber
   
    Set RegExp = CreateObject("vbscript.regexp")
    RegExp.Global = True
    RegExp.MultiLine = True
    RegExp.IgnoreCase = True
   
    ' Use titles as file names:
    'RegExp.Pattern = "src=""([^""]+)""\s+o:title=""{0,1}([^""]*)""{0,1}"
    ' Use alt tags as files names:
    RegExp.Pattern = "v:imagedata src=""([^""]+)"" o:title=.*\s.*\s.*\s.*\s.*\s.*\s.*\s.*\s.* alt=""{0,1}([^""]*)""{0,1} v:shapes="""
   
    On Error Resume Next
    Set Matches = RegExp.Execute(FileData)
    On Error GoTo 0
    If Not Matches Is Nothing Then
        If Matches.Count > 0 Then
            For Index = 0 To Matches.Count - 1
                If Len(Matches(Index).SubMatches(1)) > 0 Then
                    FileCopy TargetHTMLFolder & "\" & Replace(Matches(Index).SubMatches(0), "/", "\"), TargetImagesFolder & "\" & Matches(Index).SubMatches(1) & Mid(Matches(Index).SubMatches(0), InStrRev(Matches(Index).SubMatches(0), "."))
                Else
                    FileCopy TargetHTMLFolder & "\" & Replace(Matches(Index).SubMatches(0), "/", "\"), TargetImagesFolder & "\" & Replace(Matches(Index).SubMatches(0), "/", "\")
                End If
            Next Index
        End If
    End If
    On Error Resume Next
    Kill TargetHTMLFile
    CreateObject("Scripting.FileSystemObject").GetFolder(TargetHTMLFolder).Delete
    On Error GoTo 0

End Sub

Kevin
0
 
rodojohnAuthor Commented:
excellent and fast answer
thanks zorvek  the macro warked perfect
again I send hi from Greece
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 4
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now