Hi,
I think this is more of a Windows query than Excel but hopefully someone
can help either way.
Due to the nature of our business we have a lot of uses that add pictures
to Excel spreadsheets. Unfortunately they have got into the habit of
copying & pasting the images, rather than adding them via the Insert ->
Picture -> From File, meaning that the resultant file sizes are
tremendously high, especially when 20+ images are added to one spreadsheet.
Hi Jason,
I use the following script to reduce xls file size.
(Translated from Japanese and tested on Excel2003 MUI.)
' FileName DietXLSE.vbs
' Ver. 2.1 2005/07/04
' Auto Calculation Reserve
' Translated 2006/08/08
Option Explicit
Const msoComment = 4, msoFormControl = 8
Const msoEmbeddedOLEObject = 7, msoPicture = 13
Const TKey = "HKCR\Excel.Sheet.8\shell\DietPict\"
Const Menu = "Picture2&Jpeg"
Dim Args, xlApp, FS, tmpBook, Mag, Th
Set Args = WScript.Arguments
Select Case Args.Count
Case 0: Reg_UnReg TKey, Menu
Case 1: If LCase(Right(Args(0), 4)) = ".xls" Then Diet Args(0)
End Select
'
Sub Diet(Target)
Const xlAutomatic = -4105, xlManual = -4135
Dim aSheet, aShape, sDic, iMax, I, tmpPath, S
Mag = InputBox("Specify Picture's Quality." & vbCrLf & _
"1.0 - 3.0 (Low - High)", "Quality", "1.0")
If Mag = "" Or Not IsNumeric(Mag) Then
Mag = 2
Else
Mag = CSng(Mag)
If Mag < 1 Or Mag > 3 Then Mag = 2
End If
Th = InputBox("Specify Threshold Size of Target Object." & vbCrLf & _
"50 - 150 KB", "Threshold", "50")
If Th = "" Or Not IsNumeric(Th) Then
Th = 50
Else
Th = CSng(Th)
If Th < 50 Or Th > 150 Then Th = 50
End If
S = Timer
Set FS = CreateObject("Scripting.FileSystemObject")
Set xlApp = CreateObject("Excel.Application")
Set sDic = CreateObject("Scripting.Dictionary")
With xlApp
.Visible = True
Set tmpBook = .Workbooks.Add(1)
.Calculation = xlManual: .CalculateBeforeSave = False
tmpBook.Windows(1).Visible = False
.DisplayAlerts = False
tmpBook.SaveAs "TmpBook.xls": tmpPath = tmpBook.Fullname
.DisplayAlerts = True
With .Workbooks.Open(Target, False)
For Each aSheet In .Worksheets
sDic.RemoveAll: iMax = 1: aSheet.Select: aSheet.Cells(1).Select
For Each aShape In aSheet.Shapes
If aShape.Type <> msoComment And aShape.Type <> msoFormControl Then
sDic.Add aShape.ZorderPosition, aShape
If iMax < aShape.ZorderPosition Then iMax = aShape.ZorderPosition
End If
Next
For I = 1 To iMax
If sDic.Exists(I) Then
Set aShape = sDic.Item(I)
Select Case aShape.Type
Case msoPicture, msoEmbeddedOLEObject
ToJpeg aShape
Case Else
NoChange aShape
End Select
End If
Next
aSheet.Cells(1).Select
Next
.Sheets(1).Select
.Application.Calculation = xlAutomatic
.SaveAs Replace(Target, ".xls", "_diet.xls", 1, -1, 1)
.Close
End With
tmpBook.Close False: Set tmpBook = Nothing
FS.DeleteFile tmpPath
.Quit
End With
Set sDic = Nothing: Set xlApp = Nothing: Set FS = Nothing
With CreateObject("WScript.Shell")
.SendKeys "{F10}{ESC}"
.PopUp "Diet has been completed ! Convert$B!!(BTime :" & _
Timer - S & " sec", 3
End With
End Sub
Sub ToJpeg(Target)
Dim L, T, H, W, Z
With Target
L = .Left: T = .Top: H = .Height: W = .Width: Z = .ZOrderPosition
.LockAspectRatio = True: .Width = W * Mag : .Cut
End With
If GetObjSize > Th Then
xlApp.ActiveSheet.PasteSpecial "Picture (JPEG)"
Else
xlApp.ActiveSheet.Paste
End If
With xlApp.Selection.ShapeRange(1)
.Left = L: .Top = T: .Height = H: .Width = W
End With
End Sub
'
Sub NoChange(Target)
Dim L, T, H, W, Z
With Target
L = .Left: T = .Top: H = .Height: W = .Width: Z = .ZOrderPosition: .Cut
End With
xlApp.ActiveSheet.Paste
If TypeName(xlApp.Selection) <> "ChartArea" Then
With xlApp.Selection.ShapeRange(1)
.Left = L: .Top = T: .Height = H: .Width = W
End With
Else
With xlApp.Selection.Parent.Parent
.Left = L: .Top = T: .Height = H: .Width = W
End With
xlApp.ActiveSheet.Cells(1).Select
End If
End Sub
Function GetObjSize()
tmpBook.WorkSheets(1).Paste
tmpBook.Save
With FS.GetFile(tmpBook.FullName)
GetObjSize = .Size / 1024
End With
tmpBook.WorkSheets(1).Shapes(1).Delete
End Function
'
Sub Reg_UnReg(TKey, Menu)
Dim EN
With CreateObject("WScript.Shell")
On Error Resume Next: .RegRead TKey: EN = Err.Number: On Error GoTo 0
If EN <> 0 Then
.RegWrite Tkey, Menu
.RegWrite Tkey & "command\", _
"wscript """ & WScript.ScriptFullName & """ ""%L"""
.PopUp "Added to the context menu.", 2,"Add"
Else
.RegDelete Tkey & "command\": .RegDelete Tkey
.PopUp "Deleted from the context menu.", 2,"Delete"
End If
End With
End Sub
