I once had a client who scanned in hundreds of old photographs directly into Microsoft Word file only to need them in their raw formats for use in another application.
Needless to say it wasn’t favourable to redo the hours of scanning to save them as JPEGs or similar and hence I was called in to see if there wasn’t an easier way to do things.
Whilst there are old scripts knocking around, they weren’t foolproof as they split out the images in BMP format and often corrupted the images and left damaged pixels for one or other reason. With a bit of hacking and help from the chaps below I was able to run the below as a macro and save the day!
I hope it helps someone in a similar situation. It was a while ago and I cannot remember if I am giving all credit where it is due so apologies if I have missed someone out.
As far as I can remember this would work with most variants of Office files such as Excel and Powerpoint too.
Below is a script of VBA code which can be used as a macro to loop through a directory of files with an optional mask, opening and saving and then closing the documents.
By saving as html files the images are split out in a more coherent manner than if they were saved out as bitmaps via another VBA script which has left a cross of damaged pixels on the centre of the image and from top-bottom & left-right.
The FilePathSearch2007 function is credited to a chap in the forums called Phil_V http://www.excelforum.com/excel-programming/690124-application-filesearch-excel-2007-update.html and is used as a workaround to the “With Application.filesearch” method which worked on version prior to Office 2007.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
Sub LoopThroughFilesInFolder() Dim i As Integer Dim docDoc As Document Dim all_fileslist() As Variant Call FilePathSearch2007(all_fileslist(), "F:\test") For i = 1 To UBound(all_fileslist) ' Message box for informational purposes only ' MsgBox "File #" & i & " is " & all_fileslist(i) Set docDoc = Documents.Open(filename:=all_fileslist(i)) docDoc.SaveAs filename:="F:\temp\" & i & ".htm", FileFormat:= _ wdFormatHTML, LockComments:=False, Password:="", AddToRecentFiles:=True, _ WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _ SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _ False docDoc.Close (wdSaveChanges) Next i End Sub Function FilePathSearch2007(ByRef found_files() As Variant, path_to_search As String, Optional file_filter As String = "*.*") As Boolean ' Will search for files matching the pattern in path_to_search. ' If files are found then they are placed into the dynamic array 'found_files' passed to the function, and TRUE is returned ' If no files are found then FALSE is returned Dim filename As String Dim tempfile As String Dim index1 As Long, index2 As Long Dim index As Long ' If not trailing "\" then add one If Right(path_to_search, 1) <> "\" Then path_to_search = path_to_search & "\" filename = Dir(path_to_search & file_filter) If filename = "" Then FilePathSearch2007 = False Exit Function End If ' Size the found_array so that we 'should' get all the results in ReDim found_files(1 To 100) index = 1 found_files(index) = path_to_search & filename Do filename = Dir If filename = "" Then Exit Do If index Mod 100 = 0 Then ReDim Preserve found_files(1 To index + 100) index = index + 1 found_files(index) = path_to_search & filename Loop ReDim Preserve found_files(1 To index) FilePathSearch2007 = True End Function |