Excel renaming Activex Controls on other computers - vba

I have a worksheet with Activex Controls(Combobox, Command Button, Option Button, CheckBox).
On my computer I have renamed all the controls (Ex. CButtonPMR, OButton_Comp, etc)
But when I open the file on other computer all the controls are renamed to default the default names (CheckBox1,Checkbox2, CommandButton1, etc)
For that reason the code doesn't works on other computers.
I am getting errors every time because the code can't compile.
Is there a way to fix this?
I basically have 2 forms into one and there is 2 option button to chose wich one you want.
When the user select a Button the other form is Hidden
Private Sub OpButtonComp_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim protect As Boolean
protect = False
If ActiveSheet.ProtectContents Then
protect = True
ActiveSheet.Unprotect Password:="password"
End If
Application.ScreenUpdating = False
ActiveSheet.Rows("13:61").Hidden = True
ActiveSheet.Rows("62:86").Hidden = False
ActiveSheet.Rows("6").Hidden = True
Dim rng As Range
Set rng = ActiveSheet.Range("A62:P62")
With ActiveSheet.OLEObjects("CButtonPMB")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonPMB").Visible = True
Set rng = ActiveSheet.Range("A72:P72")
With ActiveSheet.OLEObjects("CButtonMQSB")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonMQSB").Visible = True
Set rng = ActiveSheet.Range("A79:P79")
With ActiveSheet.OLEObjects("CButtonMQS2B")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonMQS2B").Visible = True
Set rng = ActiveSheet.Range("A85:P85")
With ActiveSheet.OLEObjects("CButtonPM2B")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonPM2B").Visible = True
Application.ScreenUpdating = True
If Not (ActiveSheet.ProtectContents) And protect = True Then
ActiveSheet.protect Password:="password"
End If
End Sub
Private Sub OpButtonCon_Click()
Dim protect As Boolean
protect = False
If ActiveSheet.ProtectContents Then
protect = True
ActiveSheet.Unprotect Password:="password"
End If
Application.ScreenUpdating = False
ActiveSheet.Rows("13:61").Hidden = False
ActiveSheet.Rows("62:86").Hidden = True
ActiveSheet.Rows("6").Hidden = False
ActiveSheet.CButtonPMB.Visible = False
ActiveSheet.CButtonMQSB.Visible = False
ActiveSheet.CButtonMQS2B.Visible = False
ActiveSheet.CButtonPM2B.Visible = False
Application.ScreenUpdating = True
If Not (ActiveSheet.ProtectContents) And protect = True Then
ActiveSheet.protect Password:="password"
End If
End Sub
This is to pop up a DatePicker Form when those cells are selected.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Only look at that range
If Intersect(Target, Range("N12:P12")) Is Nothing _
And Intersect(Target, Range("N15:P15")) Is Nothing _
And Intersect(Target, Range("N29:P29")) Is Nothing _
And Intersect(Target, Range("N37:P37")) Is Nothing _
And Intersect(Target, Range("N44:P44")) Is Nothing _
And Intersect(Target, Range("N50:P50")) Is Nothing _
And Intersect(Target, Range("N51:P51")) Is Nothing _
And Intersect(Target, Range("N59:P59")) Is Nothing _
And Intersect(Target, Range("N70:P70")) Is Nothing _
And Intersect(Target, Range("N78:P78")) Is Nothing _
And Intersect(Target, Range("N83:P83")) Is Nothing Then
Exit Sub
Else
'Show Datepicker
CalendarFrm.Show
End If
End Sub
Thank you
Since my answer was deleted I'll post the solution here.
If anyone is wondering, I managed to fix it by following this http://www.excelclout.com/microsoft-update-breaks-excel-activex-controls-fix/
Copy and paste the following VBA code into any module in the spreadsheet.
Public Sub RenameMSFormsFiles()
Const tempFileName As String = "MSForms - Copy.exd"
Const msFormsFileName As String = "MSForms.exd"
On Error Resume Next
'Try to rename the C:\Users\[user.name]\AppData\Local\Temp\Excel8.0\MSForms.exd file
RenameFile Environ("TEMP") & "\Excel8.0\" & msFormsFileName, Environ("TEMP") & "\Excel8.0\" & tempFileName
'Try to rename the C:\Users\[user.name]\AppData\Local\Temp\VBE\MSForms.exd file
RenameFile Environ("TEMP") & "\VBE\" & msFormsFileName, Environ("TEMP") & "\VBE\" & tempFileName
End Sub
Private Sub RenameFile(fromFilePath As String, toFilePath As String)
If CheckFileExist(fromFilePath) Then
DeleteFile toFilePath
Name fromFilePath As toFilePath
End If
End Sub
Private Function CheckFileExist(path As String) As Boolean
CheckFileExist = (Dir(path) <> "")
End Function
Private Sub DeleteFile(path As String)
If CheckFileExist(path) Then
SetAttr path, vbNormal
Kill path
End If
End Sub
Call the RenameMSFormsFiles subroutine at the very beginning of the workbook_Open event.
Private Sub Workbook_Open()
RenameMSFormsFiles
End Sub

Related

dropdown list with autocomplete/ suggestion in excel vba

In a merged cell (named as SelName) I have a dropdown list with more then 100 items. Searching through the list is not efficient, as this list is constantly growing. Therefore, I would like to have a dropdown list with autocomplete/ suggestion function. One of the codes that I have is the following which I have found on extendoffice.com:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2017/8/15
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim Cancel As Boolean
Set xWs = Application.ActiveSheet
'On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
First, I tried to test it in an empty sheet (with just the dropdown list) and it worked well. But as soon as I try to insert this code into the other worksheet, it doesn't. Does anyone has an idea what the problem could be?
FYI: I have several drop down lists in this worksheet and all of them are in merged cells. Additionally, I have some other Private subs...
Why do you have to do that instead of just creating a ComboBox control and setting ListFillRange and LinkedCell without any code?
The error happens because the Range you are editing (Target) does not have any Validation. You should add the check for validation:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim vType As XlDVType
On Error GoTo EndLine
vType = Target.Validation.Type
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim Cancel As Boolean
Set xWs = Application.ActiveSheet
'On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If vType = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
EndLine:
End Sub
EDIT
If i understand the problem correctly, you want a ComboBox that auto-fills from a column and auto-updates if you type more entries in the column. There is no need for such complicated code. You can simply add a ComboBox (say ComboBox1), set its ListFillRange (e.g. to A1:A20) and do this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ComboBox1
Dim OrigRange As Range: OrigRange = .ListFillRange
If Not Application.Intersect(OrigRange, Target) Is Nothing Then
.ListFillRange = .OrigRange.Resize(OrigRange.Cells(1).End(xlDown).Row - OrigRange.Row + 1)
End If
End With
End Sub
Autocomplete Dropdowns are now native with excel O365
https://www.excel-university.com/autocomplete-for-data-validation-dropdown-lists/

Unable to take screenshot (JPEG) of a defined range

I am trying to take a screenshot of a range with a button and put the JPEG in the same folder. The defined range is 'header'
It runs fine for some time then all of sudden I get one of the following errors.
Vba code:
Sub CommandB_Click()
dt = Format(CStr(Now), "yy_mm_dd_hh_mm")
Const FName As String = "Screenshotzx.jpg"
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = ActiveSheet.Range("header")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = 1400
.Height = 720
End With
ChTemp.Export Filename:=ThisWorkbook.Path & "\" & "Scrnsht.jpg", FilterName:="jpg"
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Error Code 13 Type Mismatch on the following line
Set PicTemp = Selection
Error Code 1004 on the following line
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
What about something like this (gets rid of unused variables dt and Fname and avoids ActiveSheet, ActiveChart and Selection)? Note that this uses AddChart2, which is only available in Excel 2013 and later.
Sub SaveRangeAsJPEG()
Dim pic_rng As Range
Dim ChTemp As Chart
Dim ShTemp As Worksheet
Application.ScreenUpdating = False
Set pic_rng = Sheets("YourSheetName").Range("header") 'change to your sheet name
Set ShTemp = Worksheets.Add
Set ChTemp = ShTemp.Shapes.AddChart2.Chart
pic_rng.CopyPicture xlScreen, xlPicture
ChTemp.Paste
With ChTemp.ChartArea
.Width = 1400
.Height = 720
End With
ChTemp.Export Filename:=ThisWorkbook.Path & "\" & "Scrnsht.jpg", FilterName:="jpg"
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

How to set picture aspect ratio?

Sub ExampleUsage()
Dim myPicture As String, myRange As Range
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
Set myRange = Selection
InsertAndSizePic myRange, myPicture
End Sub
Sub InsertAndSizePic(Target As Range, PicPath As String)
Dim p As Object
Application.ScreenUpdating = False
Set p = ActiveSheet.Pictures.Insert(PicPath)
If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
With Target
p.Top = .Top
p.Left = .Left
p.Width = .Width
p.Height = .Height
End With
End Sub
This is my code for Microsoft Excel. I want to have the aspect ratio unlock so that I can fill the entire merged cell. Thanks in advance.
This is how you'll set the Aspect Ratio. It is a Property of the Shape Object. p is of Picture Object Type. You can use it's name to access it via Shapes which has the Aspect Ratio property:
Sub InsertAndSizePic(Target As Range, PicPath As String)
Dim p As Object
Application.ScreenUpdating = False
Dim sh As Worksheet: Set sh = ActiveSheet
Set p = sh.Pictures.Insert(PicPath)
sh.Shapes(p.Name).LockAspectRatio = False
If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
With Target
p.Top = .Top
p.Left = .Left
p.Width = .Width
p.Height = .Height
End With
Application.ScreenUpdating = True
End Sub
I declared and set variable for Worksheet Object just to have Intellisense kick in to get the arguments.
Another way is to use Shape Object AddPicture Method like below.
Sub InsertAndSizePic(Target As Range, PicPath As String)
Dim s As Shape
Application.ScreenUpdating = False
Dim sh As Worksheet: Set sh = ActiveSheet
If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
With Target
Set s = sh.Shapes.AddPicture(PicPath, True, True, .Left, .Top, .Width, .Height)
End With
Application.ScreenUpdating = True
End Sub
This code will also accomplish what the first code does. HTH.

When locking a sheet, the VB Code stops working

Here is my code; when I lock the sheet the code stops working and will not pop up on the double click.
On another note is there a way to activate the code without requiring it to double click?
Private Sub Worksheet_Activate()
End Sub
'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Set cboTemp = ws.OLEObjects("NameBox")
On Error Resume Next
With cboTemp
'clear and hide the combo box
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo errHandler
If Target.Validation.Type = 3 Then
'if the cell contains a data validation list
Cancel = True
Application.EnableEvents = False
'get the data validation formula
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
With cboTemp
'show the combobox with the list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = str
.LinkedCell = Target.Address
End With
cboTemp.Activate
'open the drop down list automatically
Me.NameBox.DropDown
End If
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = True
If Application.CutCopyMode Then
'allow copying and pasting on the worksheet
GoTo errHandler
End If
Set cboTemp = ws.OLEObjects("NameBox")
On Error Resume Next
With cboTemp
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
'***NOTE: if KeyDown causes problems, change to KeyUp
Private Sub NameBox_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
Case Else
'do nothing
End Select
End Sub
'====================================

Data validation and combo box in a cell - Workbook_SheetChange event not working

I have adapted the following code from Contextures website which adds combo box functionality into cells containing data validation. Though comboboxes display well where they should, I am still facing two issues.
First, I would need that after chosing value in "D4" cell, which combines data validation and combo box, the same value was displayed on other sheets in "D4" cell in the workbook. Unfortunately, after comboboxes code was added, the Workbook_SheetChange code stopped working. I assume it is because it cannot find Target in data validation/combobox cell now.
The second issue is that the Worksheet_SelectionChange code below causes screen flickering even though Application.ScreenUpdating is applied. Is there any way to get rid of it?
I would be greatful for any solutions.
EDIT:
At last I managed to find solution to first issue myself. I ommited Workbook_SheetChange event entirely and replaced with ComboShtHeader_KeyDown and ComboShtHeader_LostFocus events, both placed in the workbook sheets. These macros ensure that value of a cell changes on all sheets either on pressing Tab, Enter or click outside "D4" cell. I am placing both codes below for the case that someone faces similar issue.
The other issue with screen flickering in Worksheet_SelectionChange code persists though. Solutions are still welcome.:-)
Private Sub ComboShtHeader_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'change "D4" cell value on all sheets on pressing TAB or ENTER
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range(ActiveCell.Offset(0, -3).Address).Value = ActiveCell.Offset(0, -3).Value
End If
Next ws
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range(ActiveCell.Offset(-1, 0).Address).Value = ActiveCell.Offset(-1, 0).Value
End If
Next ws
Case Else
'do nothing
End Select
End Sub
Private Sub ComboShtHeader_LostFocus()
'change "D4" cell value on all sheets on click outside "D4" cell
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range("D4").Value = ws1.Range("D4").Value
End If
Next ws
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet, ws2 As Worksheet
Dim ComHead As OLEObject, ComBody As OLEObject
Dim Str As String
Application.ScreenUpdating = False
On Error GoTo ErrHandler
Set ws = ActiveSheet
Set ws2 = Worksheets("lists")
Set ComHead = ws.OLEObjects("ComboShtHeader")
Set ComBody = ws.OLEObjects("ComboShtBody")
On Error Resume Next
If ComHead.Visible = True Then
With ComHead
.Top = 34.5
.Left = 120
.Width = 20
.Height = 15
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If
On Error Resume Next
If ComBody.Visible = True Then
With ComBody
.Top = 34.5
.Left = 146.75
.Width = 20
.Height = 15
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If
On Error GoTo ErrHandler
'If the cell contains a data validation list
If Target.Validation.Type = 3 Then
If Target.Address = ws.Range("D4:F4").Address Then
If Target.Count > 3 Then GoTo ExitHandler
Application.EnableEvents = False
'Get the data validation formula
Str = Target.Validation.Formula1
Str = Right(Str, Len(Str) - 1)
With ComHead
'Show the combobox with the validation list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height
.ListFillRange = ws2.Range(Str).Address(external:=True)
.LinkedCell = Target.Address
End With
ComHead.Activate
'Open the dropdown list automatically
Me.ComboShtHeader.DropDown
Else
If Target.Count > 1 Then GoTo ExitHandler
Application.EnableEvents = False
'Get the data validation formula
Str = Target.Validation.Formula1
Str = Right(Str, Len(Str) - 1)
With ComBody
'Show the combobox with the validation list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height
.ListFillRange = ws2.Range(Str).Address(external:=True)
.LinkedCell = Target.Address
End With
ComBody.Activate
'Open the dropdown list automatically
Me.ComboShtBody.DropDown
End If
End If
ExitHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHandler:
Resume ExitHandler
End Sub
The second code, placed in ThisWorkbook module and currently not working:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wb1 As Workbook
Dim ws1 As Worksheet, ws As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set wb1 = ThisWorkbook
Set ws1 = Sh
On Error GoTo LetsContinue
'This should change "D4" value on all sheets, but does not work after combobox feature was added to the sheets.
If Not Intersect(Target, ws1.Range("D4")) Is Nothing Then
MsgBox Target.Address 'returns nothing
For Each ws In wb1.Worksheets
If Target.Value <> ws.Range(Target.Address).Value Then
ws.Range(Target.Address).Value = Target.Value
End If
Next ws
Else
GoTo LetsContinue
End If
LetsContinue:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Actually, the second issue that regarded screen flickering solved itself when I moved from Excel 2007 to 2013 version. It seems like some kind of bug in older version.