Got another one - Problem with Before Save Macro

[klarowe]

I am trying to set up this workbook so that it will automatically compress all of the pictures in the workbook before saving. Since I have Excel 2003, I can't just simply do it as a macro and have to set it up using SendKeys.

In addition to that, it is already set up so that as soon as the original workbook is opened as read-only, it brings up an input box to enter the job number, and then automatically saves the workbook as "number teardown.xls" in a specified folder.

Now here is the issue. When I first open the workbook as read-only it saves it correctly, but then the Compress Pictures dialogue box pops up which I do not want (want it to basically stay hidden). Once the original is saved, it works correctly there-after. But on the initial save it keeps popping the box up and won't continue without making a selection. I've also tried applying a "wait" and it seems to just wait longer before making the box pop up.

Here is the Before Save Code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Application.Run "SequentiallyNumberVisiblePagesOnly"
 
    Application.ScreenUpdating = False
    Dim Sheet As Worksheet
    Const TopLeft As String = "A1"
    For Each Sheet In ActiveWorkbook.Sheets
        Application.Goto Sheet.Range(TopLeft), Scroll:=True
    Next
        Sheets("Home").Activate
    Application.ScreenUpdating = True
 
    Dim octl As CommandBarControl
    With Selection
    Set octl = Application.CommandBars.FindControl(ID:=6382)
        Application.SendKeys "%e~"
        Application.SendKeys "%a~"
        Application.SendKeys "{ENTER}"
        octl.Execute
    End With
End Sub

And in-case you need it, here is the BeforeOpen code:

Private Sub Workbook_Open()
    Sheets("Home").ToggleButton1.Value = False
 
    Dim ws As Worksheet
    For Each ws In Sheets
    If ws.Visible Then ws.Select (False)
    Application.ScreenUpdating = False
    ActiveWindow.View = xlPageBreakPreview
    ActiveWindow.View = xlNormalView
    Sheets("Home").Select
    Next
    Application.ScreenUpdating = True
 
    If ActiveWorkbook.ReadOnly = True Then GoTo 1
    If ActiveWorkbook.ReadOnly = False Then GoTo 2
1:  Response = Application.InputBox("Enter Job Number", "Save-As", vbOKOnly)
    Sheets("Home").Range("C39") = Response
    If Response = False Then
    MsgBox "You have cancelled Save-As." & vbNewLine & "   Report was not saved!"
    Sheets("Home").Range("C39") = ""
    Exit Sub
    End If
    On Error GoTo Error
    ActiveWorkbook.SaveAs Filename:="S:\SERVICE\Shop Teardown Reports\" & Response & " teardown.xls"
2:  Exit Sub
Error: Resume 1
End Sub

Thanks in advance.

 

[Andrew Poulsom]

Try:

    PictObj.Cut
    ActiveSheet.PasteSpecial Format:="Picture (GIF)"