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]

If I understand you correctly, you can test the value of SaveAsUI, which is True for Save As and False for Save.

 

[klarowe]

If I understand you correctly, you can test the value of SaveAsUI, which is True for Save As and False for Save.

I was hoping for something like that. Where I could enter it in as a separate code for only Save, and not SaveAs. Do you know how I would go about doing that though??

 

[Andrew Poulsom]

Just put the test within your code, eg:

    If SaveAsUI = False Then
        With Selection
        Set octl = Application.CommandBars.FindControl(ID:=6382)
            Application.SendKeys "%e~"
            Application.SendKeys "%a~"
            Application.SendKeys "{ENTER}"
            octl.Execute
        End With
    End If

 

[klarowe]

Just put the test within your code, eg:

Thats what I thought, but when I put it in, I still get the Compress pictures window popping up during the initial save-as.

 

[Andrew Poulsom]

Yes, SaveAsUI is True if the Save As dialog box will be displayed (ie the user has chosen Save As), not when you SaveAs in code.

 

[klarowe]

ahhh.. so unfortunately that option will not work for me. ****.

Any other options?? Right now I have it linked to a button so its working at the moment, but the best case scenerio would be to have it automatically with save (but not save-as)

 

[Andrew Poulsom]

You could use a Global boolean. Example:

'General module
Public SavingAs As Boolean
Sub Test()
    SavingAs = True
    ThisWorkbook.SaveAs "C:\TEMP\BOOK1.XLS"
    SavingAs = False
    ThisWorkbook.Save
End Sub
 
'ThisWorkbook module
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If SavingAs = True Then
        MsgBox "Code uses Save As"
    Else
        MsgBox "Code uses Save"
    End If
End Sub

 

[klarowe]

I'll have to give that a try, but for now I found out that apparently my compress setup isn't really compressing... lol. It goes through all of the steps but doesn't end up compressing the pictures (end file size is the same on a compressed vs. non-compressed test)

 

[klarowe]

Onto my compress issue. I notice that if I cut a picture and paste special as a .gif then I can knock the size down quite a bit. Is there a way to modify my code here:

Sub Load_Image()
Dim myPictureName As Variant
Dim myCurFolder As String
Dim myNewFolder As String
myCurFolder = CurDir
myNewFolder = "S:\SERVICE\Shop Pictures"
ChDrive myNewFolder
ChDir myNewFolder
myPictureName = Application.GetOpenFilename _
("All Pictures (*.tif; *.bmp; *.jpg; *.gif; *.jpeg; *.png; *.cpt; *.tiff),*.tif; *.bmp; *.jpg; *.gif; *.jpeg; *.png; *.cpt; *.tiff")
ChDrive myCurFolder
ChDir myCurFolder
If myPictureName = False Then End
    Range("C35").Select
    Set PictObj = ActiveSheet.Pictures.Insert(myPictureName)
    With PictObj
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Width = 145#
    End With
        PictObj.Select
End Sub

To insert it as a .gif file. Or is there a way to select it, cut it, and paste it as a .gif?