Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer '------------------------------------------------------------------------------ 'Pictures compression routine, 3 arguments. ' 'SelectedPictureOnly: True if to be applied to the currently selected picture ' False if to be applied to all pictures of the Worksheet ' 'dpi: 0 (for default value), 96, 150, 220, 330 ' 'UserValidation: True if the Excel Compression Panel is to be displayed ' for User validation ' User valisation assumes the user hits Enter ! ' False if done transparently without User validation ' 'Example: Call PicturesCompress(False, 96, False) '------------------------------------------------------------------------------ Public Sub PicturesCompress(SelectedPictureOnly As Boolean, dpi As Integer, UserValidation As Boolean) Static AllPictures As Boolean Dim InitialNumLockState As Boolean Dim SendA As Boolean Dim CompressionChar As String 'French -> "C" = 96 ppp, "W" = 150 ppp, "I" = 220 ppp, "H" = 330 ppp, "U" = Excel default 'English-> "E" = 96 dpi, "W" = 150 dpi, "P" = 220 dpi, "H" = 330 dpi, "U" = Excel default Const EnterChar = "~" 'Char for Enter in SendKeys Const Language = "French" '"French" or "English" 'Check if at least 1 picture is present If ActiveSheet.Pictures.Count = 0 Then MsgBox "There is no picture in the Worksheet." Exit Sub End If 'Check dpi Select Case dpi Case 0 If Language = "French" Then CompressionChar = "U" Else CompressionChar = "U" Case 96 If Language = "French" Then CompressionChar = "C" Else CompressionChar = "E" Case 150 If Language = "French" Then CompressionChar = "W" Else CompressionChar = "W" Case 220 If Language = "French" Then CompressionChar = "I" Else CompressionChar = "P" Case 330 If Language = "French" Then CompressionChar = "H" Else CompressionChar = "H" Case Else MsgBox "Parameter dpi can only be 0 (for default compression value), 96, 150, 220 or 330." Exit Sub End Select '--------------------------------------------------------------------------- 'Picture selection is MANDATORY to display the Excel 2007+ Compression Panel 'Otherwise the Excel 2003 Compression Panel will be displayed and this one 'is completely INOPERANT in Excel 2007+ even though it seems to work. '--------------------------------------------------------------------------- 'Check SelectedPictureOnly If SelectedPictureOnly Then If TypeName(Selection) <> "Picture" Then MsgBox "Compression is called for the selected picture only, but no picture is currently selected." Exit Sub End If Else If TypeName(Selection) <> "Picture" Then ActiveSheet.Pictures(1).Select 'Select the 1st picture End If End If 'Get initial keyboard Num Lock state InitialNumLockState = CBool(GetKeyState(144)) '------------------------------------------- '"Apply to the selected picture only" option '------------------------------------------- 'There is no determinist action for this option as the selection by "A" is alternatively ON & OFF 'On the 1st time the option is ticked ON by default 'On the following times the option keeps the value ON/OFF it was previously set (assuming Enter was done previously when User Validation) Select Case SelectedPictureOnly Case True If AllPictures Then SendA = True Else SendA = False Case False If AllPictures Then SendA = False Else SendA = True End Select If SendA Then Application.SendKeys "A", True AllPictures = Not AllPictures End If '------------------ 'Compression option '------------------ Application.SendKeys CompressionChar, True '--------------------------------- 'Enter if no prior User Validation '--------------------------------- If Not UserValidation Then Application.SendKeys EnterChar, True 'SendKeys are messing up the Num Lock If InitialNumLockState Then Application.SendKeys "{NUMLOCK}", True 'Launch the Compression Panel Application.CommandBars.ExecuteMso "PicturesCompress" End Sub