I use a macro to automatically compress pictures in Excel 2010, the macro opens a dialog and sendkeys, and final users can see it (for half a second), i want to hide it. Please help !
This is my macro:
Sub compression()
Application.SendKeys "%w~"
Application.CommandBars.ExecuteMso "PicturesCompress"
End Sub
I already tried:
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
But they don't seem to work.
#TomPreston
Here's my whole code, i want users to double click on type of cells to insert pictures in comments but the pictures must be compressed to keep the file fit !
I ALSO have problems with sendkeys and num lock, if someone can help me on this (see below):
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, [v:v]) Is Nothing Then
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialFileName = CurDir
.Filters.Clear
.Filters.Add Description:="Images", Extensions:="*.png;*.jpg;*.jpeg;*.gif", Position:=1
.Title = "Choose image"
If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
End With
If TheFile = 0 Then
MsgBox ("No image selected")
Exit Sub
End If
ActiveCell.ClearComments
Selection.AddComment
PreviousCell = ActiveCell.Address
ActiveCell.Comment.Shape.Fill.UserPicture TheFile
NumLockState = GetKeyState(VK_NUMLOCK)
Application.SendKeys "%a~"
Application.CommandBars.ExecuteMso "PicturesCompress"
If NumLockState <> GetKeyState(VK_NUMLOCK) Then
Application.SendKeys ("%{Numlock}"), True
End If
ActiveCell.Comment.Visible = True
CommentAdded = True
Application.ScreenUpdating = True
End If
End Sub
Users can change de size of the picture and after the selection change, the comment is hidden.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If CommentAdded = True Then
Range(PreviousCell).Comment.Visible = False
PreviousCell = ""
CommentAdded = False
End If
End Sub
And these are the variables:
Public CommentAdded As Boolean
Public PreviousCell As String
Public Const VK_NUMLOCK = &H90
Public Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Long
If you just want to hide the flicker effect, use this:
Sub compression()
Application.ScreenUpdating = False
Application.SendKeys "%w~" Application.CommandBars.ExecuteMso "PicturesCompress"
Application.ScreenUpdating = True
End Sub
Related
It has been a while i'm blocked with vba code running when event occured.
For a brief explanation, before the user save the file a userform pop-up in order to select the name for the file and the version. When he click continue, the getsaveasfilename start and the file will save in the proper location. Nevertheless, when saving the workbook crash and excel close all the file.
Please see below the code :
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sfile, mbox As Variant, cell_path As String
dialog:
save_file.Show
cell_path = ActiveWorkbook.Sheets("ENGINE").Range("H1") & " CAPEX " & ActiveWorkbook.Sheets("ENGINE").Range("I1")
sfile = Application.GetSaveAsFilename(cell_path, "Excel Macro Files, *.xlsm")
If sfile = False Then
Cancel = True
Exit Sub
End If
If Dir(sfile) = "" Then
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveWorkbook.SaveAs sfile
Application.DisplayAlerts = True
Exit Sub
Else: mbox = MsgBox("The file already exist, do you want to overwrite ?", vbYesNo, "WARNING")
If mbox = vbYes Then
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveWorkbook.SaveAs sfile
Application.DisplayAlerts = True
Else: GoTo dialog
End If
End If
Application.EnableEvents = True
End Sub
EDIT: Posted full userform code
this is my userform
What I need to do, is load a csv, and a second csv essentially with updated price. I'm then using vlookup to match data. I just cant get my code to compile while I try to target MyVal2 with Module3.
Book1 is a remnant from recording a macro testing how it'd work.
Public MyVal1 As String 'AUS URL'
Public MyVal2 As String 'scrape'
Private Sub CommandButton1_Click()
Workbooks.OpenText Filename:=(MyVal1)
Workbooks.OpenText Filename:=(MyVal2)
Application.Run "Module2.AuscompDataSheet"
Application.Run "Module3.AuscompDataSheet"
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
Private Sub CommandButton2_Click()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
TextBox1 = .SelectedItems(1)
End If
End With
End Sub
Private Sub CommandButton3_Click()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
TextBox2 = .SelectedItems(1)
End If
End With
End Sub
Private Sub TextBox1_Change()
MyVal1 = UserForm1.TextBox1.Value
End Sub
Private Sub TextBox2_Change()
MyVal2 = UserForm1.TextBox2.Value
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
End Sub
MODULE 3:
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],[MyVal2]Sheet1!R2C1:R5C3,3,FALSE)"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D7"), Type:=xlFillDefault
Range("D2:D7").Select
I think the problem is that you are assigning the value of the variables myVal1 and MyVal2 by changing the assignment in the CommandButton1 instead of doing it in the textboxes and at the beginning of the code as a public declaration.
Private Sub CommandButton1_Click()
Dim MyVal2, MyVal1 as string
MyVal2 = UserForm1.TextBox2.Value
MyVal1 = UserForm1.TextBox1.Value
Workbooks.OpenText Filename:=(MyVal1)
Workbooks.OpenText Filename:=(MyVal2)
call AuscompDataSheet
call AuscompDataSheet
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
I have an Exit button on a userform. If the user clicks it I want it to return Excel's settings to it's original values and then close the workbook. The code in the Exit button is as follows:
Unload Me
If g_Released Then
ThisWorkbook.Close savechanges:=False
End If
The code in the Workbook_BeforeClose event is:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim bSaved As Boolean
bSaved = ThisWorkbook.Saved
ActiveWindow.DisplayWorkbookTabs = True
'more code here
The last line does not cause the workbook tabs to be displayed. Further in the code I also try to set things like Application.DisplayFormulaBar = True and so forth, but none of them have any impact. It appears as if these properties has somehow been forced into a read-only state, but I don't know why.
Edit: Here is the complete code.
Private Sub Workbook_Open()
InitialiseVariables
Application.ScreenUpdating = False
HideExcelUI Application, False, True, False, "Some Company", "Budgeting Module Release 0.1", ThisWorkbook.Path & "\Logo.ico"
HideWorksheetsUI False, False, False
wsBackground.Select
With Application
.WindowState = xlNormal
.Height = frmMain.Height
.Width = frmMain.Width
End With
Application.ScreenUpdating = True
DisplayFormInCenter frmMain
End Sub
Public Sub InitialiseVariables()
g_tDBfolder = ThisWorkbook.Path & "\"
Set g_cn = New ADODB.Connection
With g_cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Data Source") = g_tDBfolder & g_tDBname
.Open
End With
g_ScenarioIsSaved = True
g_ScenarioID = CLng([Scenario_ID])
Set g_rBudgetYear = [BudgetYear]
Set g_rStartMonth = [StartMonth]
Set g_rDealerName = [DealerName]
Set g_rScenario = [Scenario]
End Sub
Public Sub HideExcelUI(ByRef xlApp As Excel.Application, _
ByVal ShowFormulaBar As Boolean, ByVal ShowScrollBars As Boolean, ByVal ShowStatusBar As Boolean, _
Optional ByVal strApplicationCaption As String, Optional ByVal strWindowCaption As String, Optional ByVal strIcoFile As String)
With xlApp
.ExecuteExcel4Macro "SHOW.TOOLBAR(""RIBBON"",FALSE)"
.DisplayFormulaBar = ShowFormulaBar
.DisplayScrollBars = ShowScrollBars
.DisplayStatusBar = ShowStatusBar
If strApplicationCaption <> "" Then
.Caption = strApplicationCaption
End If
If strWindowCaption <> "" Then
.Windows(1).Caption = strWindowCaption
End If
If strIcoFile <> "" Then
SetIcon strIcoFile, 0
End If
End With
End Sub
Public Sub HideWorksheetsUI(ByVal ShowGridlines As Boolean, ByVal ShowHeadings As Boolean, ByVal ShowWorkbookTabs As Boolean)
Dim ws As Worksheet, wsCurrent As Worksheet
Application.ScreenUpdating = False
Set wsCurrent = ActiveSheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayWorkbookTabs = False
.Caption = ""
End With
Next
wsCurrent.Activate
Application.ScreenUpdating = True
End Sub
Public Sub DisplayFormInCenter(ByVal objForm As Object, Optional ByVal bModeless As Boolean)
With objForm
.startupposition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
If bModeless Then
.Show vbModeless
Else
.Show
End If
End With
End Sub
Private Sub ExitButton_Click()
Unload Me
If g_Released Then
ThisWorkbook.Close savechanges:=False
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim bSaved As Boolean, Success As Boolean
Dim UserResponse As Long
bSaved = ThisWorkbook.Saved
ActiveWindow.DisplayWorkbookTabs = True
If g_Released Then
If Not g_ScenarioIsSaved Then
UserResponse = MsgBox(Prompt:="There are unsaved changes in the current budget. Save changes?", Buttons:=vbYesNoCancel)
If UserResponse = vbYes Then
Success = SaveInputs(ActiveSheet)
If Not Success Then
MsgBox "Unexpected error. All inputs were not saved. Please contact vendor."
End If
ElseIf UserResponse = vbNo Then
'Go ahead and close
Else
Cancel = True
End If
End If
End If
ResetIconToExcel
ThisWorkbook.Saved = bSaved
End Sub
This is a follow up from this question, Lock Cells after Data Entry. I have progressed from asking that question but encountered more problems so felt I should ask a new question. The workbook is edited by multiple users. To prevent tampering with previous data the cells are locked once data has been entered and the file saved.
I have a couple of small bugs in the code:
If the user chooses to SaveAs then tries to save over an existing file the usual ' Do you want to replace this file?' dialog appears. If the user selects no there is a run time error. I have highlighted where the error is in the code below but I am unsure how to fix it.
If the user has entered data then tries to exit and save the file using the save dialog box that appears on close the file is saved but the data is not locked. I have been trying to call my main code to lock the cells upon an exit save but I keep encountering argument not optional errors.
Here is the full code:
Option Explicit
Const WelcomePage = "Macros"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Written by Alistair Weir (alistair.weir#communitypharmacyscotland.org.uk, http://alistairweir.blogspot.co.uk/)
Dim ws As Worksheet
Dim wsActive As Worksheet
Dim vFilename As Variant
Dim bSaved As Boolean
'Turn off screen updating
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Record active worksheet
Set wsActive = ActiveSheet
'Prompt for Save As
If SaveAsUI = True Then
MsgBox "Are you sure you want to save? Data entered cannot be edited once the file has been saved. Press cancel on the next screen to edit your data or continue if you are sure it is correct.", vbCritical, "Are you sure?"
vFilename = Application.GetSaveAsFilename("", fileFilter:="Excel Files (*.xls), *.xls")
If CStr(vFilename) = "False" Then
bSaved = False
Else
'Save the workbook using the supplied filename
Call HideAllSheets
'--> The vFilename Variant in the next line is the problem **
'--> when trying to overwrite an existing file **
ThisWorkbook.SaveAs vFilename
Application.RecentFiles.Add vFilename
Call ShowAllSheets
bSaved = True
End If
Else
'Save the workbook, prompt if normal save selected not save As
Call HideAllSheets
If MsgBox("Are you sure you want to save? Data entered cannot be edited after saving", vbYesNo, "Save?") = vbYes Then
ThisWorkbook.Save
Call ShowAllSheets
bSaved = True
Else
Cancel = True
End If
Call ShowAllSheets
End If
'Restore file to where user was
wsActive.Activate
'Restore screen updates
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Set application states appropriately
If bSaved Then
ThisWorkbook.Saved = True
Cancel = True
Else
Cancel = True
End If
'Lock Cells before save if data has been entered
Dim rpcell As Range
With ActiveSheet
If bSaved = True Then
.Unprotect Password:="oVc0obr02WpXeZGy"
.Cells.Locked = False
For Each rpcell In ActiveSheet.UsedRange
If rpcell.Value = "" Then
rpcell.Locked = False
Else
rpcell.Locked = True
End If
Next rpcell
.Protect Password:="oVc0obr02WpXeZGy"
Else
MsgBox "The LogBook was not saved. You are free to edit the RP Log again", vbOKOnly, "LogBook Not Saved"
End If
End With
End Sub
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
ThisWorkbook.Saved = True
End Sub
'Called to hide all the sheets but enable macros page
Private Sub HideAllSheets()
Dim ws As Worksheet
Worksheets(WelcomePage).Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws
Worksheets(WelcomePage).Activate
End Sub
'Called to show the data sheets when macros are enabled
Private Sub ShowAllSheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws
Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub
Thanks :)
Edit
For now I am solving problem 2 by bypassing excel's default 'do you want to save?' by doing this:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If MsgBox("Are you sure you want to quit? Any unsaved changes will be lost.", vbYesNo, "Really quit?") = vbNo Then
Cancel = True
Else
ThisWorkbook.Saved = True
Application.Quit
End If
End Sub
I am open to suggestions of a better way and still haven't solved the first problem.
One possibility is to write your own confirmations in a save function, like so:
Private Function SaveSheet(Optional fileName) As Boolean
HideAllSheets
If fileName = "" Then
ThisWorkbook.Save
SaveSheet = True
Else
Application.DisplayAlerts = False
If Dir(fileName) <> "" Then
If MsgBox("Worksheet exists. Overwrite?", vbYesNo, "Exists") = vbNo Then Exit Function
End If
ThisWorkbook.saveAs fileName
SaveSheet = True
Application.DisplayAlerts = True
End If
ShowAllSheets
End Function
And change your original code to something like:
If SaveAsUI Then
If MsgBox( _
"Are you sure you want to save? Data entered cannot be edited once the file has been saved. " & _
"Press cancel on the next screen to edit your data or continue if you are sure it is correct.", _
vbYesNo, "Are you sure?" _
) = vbYes Then
vFilename = Application.GetSaveAsFilename("", fileFilter:="Excel Files (*.xls), *.xls")
If vFilename <> "" Then
If SaveSheet(vFilename) Then bSaved = True
End If
End If
Else
If MsgBox( _
"Are you sure you want to save? Data entered cannot be edited after saving", _
vbYesNo, "Save?" _
) = vbYes Then
If SaveSheet("") Then bSaved = True
End If
End If
I've not fully tested the above, but it should give you some ideas.
I have a spreadsheet that is edited by multiple users. To prevent tampering with previous data the cells are locked once data has been entered and the file saved. I have a few small bugs in the code though:
Even if the user has saved manually and then exits the application they are still prompted to save again.
The cells should be locked after a save when the application is running and not just when it is exited. Previously I had this code in the before_save event but the cells were being locked even if a save_as event was cancelled so I removed the code for now. Fixed
(Edit: I've just realised how obvious this error was. I even said it in this statement! Trying to lock cells after a save event using a before save event sub! )
Code
With ActiveSheet
.Unprotect Password:="oVc0obr02WpXeZGy"
.Cells.Locked = False
For Each Cell In ActiveSheet.UsedRange
If Cell.Value = "" Then
Cell.Locked = False
Else
Cell.Locked = True
End If
Next Cell
.Protect Password:="oVc0obr02WpXeZGy"
End With
The workbook open, hide all sheets and show all sheets subs are used to force the end user into enabling macros. Here is the full code:
Option Explicit
Const WelcomePage = "Macros"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim wsActive As Worksheet
Dim vFilename As Variant
Dim bSaved As Boolean
'Turn off screen updating
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Record active worksheet
Set wsActive = ActiveSheet
'Prompt for Save As
If SaveAsUI = True Then
vFilename = Application.GetSaveAsFilename("", fileFilter:="Excel Files (*.xls), *.xls")
If CStr(vFilename) = "False" Then
bSaved = False
Else
'Save the workbook using the supplied filename
Call HideAllSheets
ThisWorkbook.SaveAs vFilename
Application.RecentFiles.Add vFilename
Call ShowAllSheets
bSaved = True
End If
Else
'Save the workbook
Call HideAllSheets
ThisWorkbook.Save
Call ShowAllSheets
bSaved = True
End If
'Restore file to where user was
wsActive.Activate
'Restore screen updates
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Set application states appropriately
If bSaved Then
ThisWorkbook.Saved = True
Cancel = True
Else
Cancel = True
End If
End Sub
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
ThisWorkbook.Saved = True
End Sub
Private Sub HideAllSheets()
Dim ws As Worksheet
Worksheets(WelcomePage).Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws
Worksheets(WelcomePage).Activate
End Sub
Private Sub ShowAllSheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws
Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub
'Lock Cells upon exit save if data has been entered
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Cell As Range
With ActiveSheet
.Unprotect Password:="oVc0obr02WpXeZGy"
.Cells.Locked = False
For Each Cell In ActiveSheet.UsedRange
If Cell.Value = "" Then
Cell.Locked = False
Else
Cell.Locked = True
End If
Next Cell
.Protect Password:="oVc0obr02WpXeZGy"
End With
End Sub
Thanks :)
It is asking for them to save before exiting even though they have already saved because of these lines:
'Save the workbook
Call HideAllSheets
ThisWorkbook.Save
Call ShowAllSheets
bSaved = True
You are changing the worksheet after saving it (by calling ShowAllSheets) so it does need to be saved again. The same is true of the saveAs code.
I fixed the second problem by using another IF. This ensures the cells are only locked if the data is saved:
'Lock Cells before save if data has been entered
Dim rpcell As Range
With ActiveSheet
If bSaved = True Then
.Unprotect Password:="oVc0obr02WpXeZGy"
.Cells.Locked = False
For Each rpcell In ActiveSheet.UsedRange
If rpcell.Value = "" Then
rpcell.Locked = False
Else
rpcell.Locked = True
End If
Next rpcell
.Protect Password:="oVc0obr02WpXeZGy"
Else
MsgBox "The LogBook was not saved. You are free to edit the RP Log again", vbOKOnly, "LogBook Not Saved"
End If
End With