UserForm Object with Methods in VBA - excel

I need to create an Object representing a UserForm, with methods to add Controls, and a method to present the UserForm.
I'm having a hard time wrapping my head around object-oriented VBA, and the tutorials/answers/documentation aren't helping me.
Here's how I imagine the Object and an example of its methods.
Sub UI_Window(caption as String)
Dim Form As Object
' This is to stop screen flashing while creating form
Application.VBE.MainWindow.Visible = False
Set Form = ThisWorkbook.VBProject.VBComponents.Add(1)
With Form
.Properties("Caption") = caption
.Properties("Width") = 600
.Properties("Height") = 50
End With
return Form
Sub addButton(action as String, code as String)
Set NewButton = Form.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "cmd_1"
.Caption = action
.Accelerator = "M"
.Top = Form.Height
.Left = 50
.Width = 500
.Height = 100
.Font.Size = 14
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
' Adjust height of Form to added content
With Form
.Properties("Height") = Form.Height + NewButton.Height + 50
End With
' Should loop through code argument, line-by-line
Form.codemodule.insertlines 8, "Private Sub cmd_1_Click()"
Form.codemodule.insertlines 9, "msgbox (""Button clicked!"")"
Form.codemodule.insertlines 10, "End Sub"
End Sub
Sub present()
'Show the form
VBA.UserForms.Add(Form.Name).Show
'Delete the form
ThisWorkbook.VBProject.VBComponents.Remove Form
End Sub
End Sub
And here's how it would be used
Sub SampleWindow()
Set Window = UI_Window "Window Title"
Window.addButton "Click me", "msgbox (""Button clicked!"")"
Window.present()
End Sub

Please, try this adapted way:
Copy the next code on top of module where the following code exists:
Public frm As Object 'to use it even after the UserForm has been created
'to avoid it deletion when tested the code
Copy the next code in the same standard module:
Sub CreateAFormWithAButton()
Const formName As String = "MyNewForm"
Const formCaption As String = "My Form"
removeForm formName 'remove the previously created form, if the case
UI_Window formCaption, formName 'create the new form
addButton frm, "myFirstButton", "Click Me" 'add a button
VBA.UserForms.Add(frm.Name).Show 'show the newly created form
End Sub
Function formExists(frmName As String) As Boolean
Dim fr As Variant
For Each fr In ThisWorkbook.VBProject.VBComponents
If fr.Type = vbext_ct_MSForm Then
If frmName = fr.Name Then
Set frm = fr
formExists = True: Exit Function
End If
End If
Next
End Function
Sub UI_Window(frmCaption As String, frmName As String)
Set frm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm) '3
With frm
.Properties("Caption") = frmCaption
.Properties("Width") = 500
.Properties("Height") = 200
.Properties("Name") = frmName
End With
End Sub
Sub addButton(form As Object, btName As String, btCaption As String)
Dim NewButton As MSForms.CommandButton
If buttonExists(btName) Then MsgBox "A button named """ & btName & """ already exists...": Exit Sub
Set NewButton = form.Designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = btName
.caption = btCaption
.top = 0
.left = 50
.width = 100
.height = 40
.Font.size = 14
.Font.Name = "Tahoma"
End With
' Should loop through code argument, line-by-line
form.CodeModule.InsertLines 8, "Private Sub " & btName & "_Click()"
form.CodeModule.InsertLines 9, " msgbox (""Button clicked!"")"
form.CodeModule.InsertLines 10, "End Sub"
End Sub
Function buttonExists(btName As String) As Boolean
Dim ctrl As Variant
For Each ctrl In frm.Designer.Controls
If ctrl.Name = btName Then buttonExists = True: Exit Function
Next
End Function
Sub removeForm(frmName As String)
Dim i As Long, strName As String
If Not formExists(frmName) Then Exit Sub
strName = "TestName"
tryAgain:
On Error Resume Next
frm.Name = strName
If err.Number = 75 Then 'a previously used name...
err.Clear 'clear the error
strName = strName & i: i = i + 1 'increment the new string
frm.Name = strName: GoTo tryAgain 'test the new name again
End If
On Error GoTo 0
ThisWorkbook.VBProject.VBComponents.Remove frm
End Sub
If you will try running the code for the second time, you cannot create a button with the same name. The code check if the name exists and warn. It can be adapted to propose another name (adding an incremented number), but it needs also to set other positioning, making the code more complicated and this does not make the object of the question, I would say...
Please, run/test it and send some feedback.

Related

How to insert pictures into Excel files from entering the serial number in a cell?

I'm trying to insert pictures into Excel files from entering the serial number in a cell.
I get a syntax error where it is trying to insert the pictures. Specifically where it says .Shapes.AddPicture.
Sub picture_insert()
Dim picBild As Picture
Dim blnAvailable As Boolean
Dim link As String
Dim Pattern As String
Dim Serial As String
Dim t As String
Dim P1 As String
Dim P2 As String
link = "\\chimera\home\hillerbr\My Documents\Index project\"
Pattern = Range("A14")
Serial = Range("B14")
t = ".jpg"
P1 = Range("C14")
P2 = Range("D14")
With Worksheets("Data Breakdown")
For Each picBild In .Pictures
If picBild.Name = "280.1" Then
'The picture already exists
blnVorhanden = True
Exit For
End If
Next picBild
'only execute if picture does not yet exist
If blnVorhanden = False Then
With .Shapes.AddPicture Filename := link & Pattern & Serial & P1 & t
.Name = Range("C14")
.ShapeRange.LockAspectRatio = msoFalse
.Width = 450
.Height = 500
.Left = Worksheets("Data Breakdown").Range("A10").Left
.Top = Worksheets("Data Breakdown").Range("G20").Top
End With
With .Shapes.AddPicture Filename := link & Pattern & Serial & P1 & t
.Name = Range("D14")
.ShapeRange.LockAspectRatio = msoFalse
.Width = 450
.Height = 500
.Left = Worksheets("Data Breakdown").Range("E10").Left
.Top = Worksheets("Data Breakdown").Range("G20").Top
End With
End If
End With
End Sub
Sub Image_Remove()
Dim picBild As Picture
With Worksheets("Data Breakdown")
For Each picBild In .Pictures
If picBild.Name = Range("C14") Then
picBild.Delete
Exit For
End If
Next picBild
For Each picBild In .Pictures
If picBild.Name = Range("D14") Then
picBild.Delete
Exit For
End If
Next picBild
End With
End Sub
Providing your variables point to a valid image I found the below code works.
Sub Test()
Dim sht As Worksheet
Set sht = Worksheets("Data Breakdown")
With sht
With .Shapes.AddPicture(Filename:=link & Pattern & Serial & P1 & t, _
LinkToFile:=True, SaveWithDocument:=True, _
Left:=.Range("A10").Left, Top:=.Range("G20").Top, Width:=450, Height:=500)
.Name = "ABC"
.LockAspectRatio = True
End With
End With
End Sub
The Help page for AddPicture says there's 7 required parameters.

Having error 400 when creating several textBox when pressing a button

I have a workbook with 2 sheets (one to place the data and another for options).
The one with the data it has some buttons (at row 1), some textBox and DropBox (at row 2) and at row 3 are the headers of the table with all the data below.
The sheet with the options for the moment has only one button to recreate the menu (the TextBox and DropBox at row 2 in the data sheet)
However when pressing the button to run the macro it gives error 400 with no description and a red x signal. Sometimes it gives error when re-creating and first textBox, sometimes the second or third as well (never the fourth or the fifth).
Why does such 400 error happen ? What causing it ?
When trying debug the code i placed some Debug.Print in some places and after running 3 times (after clicking in button 3 times this is the output in the immediate window.
-----------Running createMenu-----------
TextBox5 DIM done
TextBox5 Set done
TextBox6 Delete
-----------Running createMenu-----------
TextBox5 Delete
TextBox5 DIM done
TextBox5 Set done
TextBox6 DIM done
TextBox6 Set done
TextBox7 Delete
-----------Running createMenu-----------
TextBox5 Delete
The code below (the one to recreate the menus) is placed in the data worksheet.
Sub createMenu()
Debug.Print "-----------Running createMenu-----------"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
.Range("A2").NumberFormat = "0"
.Range("B2").NumberFormat = "dd-mm-yyyy"
.Range("C2:D2").Merge
.Range("C2:D2").NumberFormat = "hh:mm:ss"
Call newTextBox(.Range("E2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("F2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("G2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("H2"))
Application.Wait (Now + TimeValue("0:00:02"))
Call newTextBox(.Range("I2"))
Call newDropBox(.Range("J2"), "=Opções!A1:A14")
Call newDropBox(.Range("K2"), "=Opções!B1:B2")
.Range("A2:N2").HorizontalAlignment = xlCenter
End With
End Sub
Sub newDropBox(t As Range, list As String)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws.Range(t.Address).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=list
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Sub newTextBox(t As Range)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
Dim OLEObj As OLEObjects
If .OLEObjects.Count > 0 Then
Dim x As Integer
For x = 1 To .OLEObjects.Count
If .OLEObjects(x).Name = "TextBox" & t.Column Then
.OLEObjects(x).Delete
Debug.Print "TextBox" & t.Column & " Delete"
End If
Next x
End If
Dim myTextBox As OLEObject
Debug.Print "TextBox" & t.Column; " DIM done"
Set myTextBox = .OLEObjects.Add("Forms.TextBox.1")
Debug.Print "TextBox" & t.Column; " Set done"
With myTextBox
.Name = "TextBox" & t.Column
.LinkedCell = t.Address
.Left = t.Cells.Left
.Top = t.Cells.Top
.Width = t.Cells.Width
.Height = t.Cells.Height
.Object.BackColor = 16777152
.Object.BorderStyle = 1
.Object.BorderColor = 0
End With
End With
End Sub
So i find out the reason ...
So when i am doing the for loop he started by finding (lets say 2 OLEObjects).
If the in the first cycle of the loop the wanted object is found he delete one of the objects making it the total OLEObjects count to less 1.
There for when cycling to the second OLEObjects he will not find it, and throw such 400 error.
So the fix i done was exit the loop when the target OLEObjects is found.
Sub newTextBox(t As Range)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Dados1")
With ws
Dim OLEObj As OLEObjects
If .OLEObjects.Count > 0 Then
Dim x As Integer
For x = 1 To .OLEObjects.Count
If .OLEObjects(x).Name = "TextBox" & t.Column Then
.OLEObjects(x).Delete
Exit For
End If
Next x
End If
Dim myTextBox As OLEObject
Set myTextBox = .OLEObjects.Add("Forms.TextBox.1")
With myTextBox
.Name = "TextBox" & t.Column
.LinkedCell = t.Address
.Left = t.Cells.Left
.Top = t.Cells.Top
.Width = t.Cells.Width
.Height = t.Cells.Height
.Object.BackColor = 16777152
.Object.BorderStyle = 1
.Object.BorderColor = 0
End With
End With
End Sub

Use VBA code for enabling checkboxes on multiple rows

enter image description hereI have a spreadsheet that has 3 checkbox options for each row, I have created a VBA to disable the other 2 checkboxes once a checkbox is created (so that only 1 checkbox can be checked), however my solution only works for one row and I need some help in rewriting this so that it will apply to all rows please. (I'm new to VBA).
The code I have used is this:
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
CheckBox2.Value = False
CheckBox2.Enabled = False
CheckBox3.Value = False
CheckBox3.Enabled = False
Else
CheckBox2.Value = False
CheckBox2.Enabled = True
CheckBox3.Value = False
CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
CheckBox1.Value = False
CheckBox1.Enabled = False
CheckBox3.Value = False
CheckBox3.Enabled = False
Else
CheckBox1.Value = False
CheckBox1.Enabled = True
CheckBox3.Value = False
CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox3_Click()
If CheckBox3.Value = True Then
CheckBox1.Value = False
CheckBox1.Enabled = False
CheckBox2.Value = False
CheckBox2.Enabled = False
Else
CheckBox1.Value = False
CheckBox1.Enabled = True
CheckBox2.Value = False
CheckBox2.Enabled = True
End If
End Sub
You should probably just use Radios it would be a lot simpler.
If you are intent on doing this you will need to delete all your boxes and then put this code in. It will create and name your boxes and assign them code on click.
Alright, This needs to go in your Sheet module:
Sub Worksheet_Activate()
'Change Module2 to whatever the module name you are using is.
Module2.ActivateCheckBoxes ActiveSheet
End Sub
This next stuff will go into the module you're referencing from the Worksheet Module.
Sub ActivateCheckBoxes(sht As Worksheet)
If sht.CheckBoxes.Count = 0 Then
CreateCheckBoxes sht
End If
Dim cb As CheckBox
For Each cb In sht.CheckBoxes
'You may be able to pass sht as an object, It was giving me grief though
cb.OnAction = "'Module2.CheckBoxClick """ & cb.name & """, """ & sht.name & """'"
Next cb
End Sub
Sub CreateCheckBoxes(sht As Worksheet)
Dim cell As Range
Dim chkbox As CheckBox
With sht
Dim i As Long
Dim prevrow As Long
prevrow = 0
For Each cell In .Range("B2:D5") 'Change this to whatever range you want.
If prevrow < cell.row Then
prevrow = cell.row
i = 0
End If
Set chkbox = .CheckBoxes.Add(cell.Left, cell.Top, 30, 6)
With chkbox
.name = "CheckBox" & i & "_" & cell.row
.Caption = ""
End With
i = i + 1
Next cell
End With
End Sub
Sub CheckBoxClick(chkname As String, sht As String)
Dim cb As CheckBox
With Worksheets(sht)
For Each cb In .CheckBoxes
If Split(cb.name, "_")(1) Like Split(chkname, "_")(1) And Not cb.name Like chkname Then
cb.Value = -4146
End If
Next cb
End With
End Sub
You do not say anything about your sheet check boxes type... Please, test the next solution. It will be able to deal with both sheet check boxes type:
Copy this two Subs in a standard module:
Public Sub CheckUnCheckRow(Optional strName As String)
Dim sh As Worksheet, s As CheckBox, chK As OLEObject ' MSForms.CheckBox
Set sh = ActiveSheet
If strName <> "" Then
Set chK = sh.OLEObjects(strName) '.OLEFormat.Object
solveCheckRow chK.Object.Value, sh, Nothing, chK
Else
Set s = sh.CheckBoxes(Application.Caller)
solveCheckRow s.Value, sh, s
End If
End Sub
Sub solveCheckRow(boolVal As Long, sh As Worksheet, chF As CheckBox, Optional chK As OLEObject)
Dim s As CheckBox, oObj As OLEObject, iCount As Long
If Not chF Is Nothing Then
For Each s In sh.CheckBoxes
If chF.TopLeftCell.Address <> s.TopLeftCell.Address Then
If s.TopLeftCell.Row = chF.TopLeftCell.Row Then
s.Value = IIf(boolVal = -4146, 1, -4146): iCount = iCount + 1
If iCount = 2 Then Exit Sub
End If
End If
Next
ElseIf Not chK Is Nothing Then
For Each oObj In sh.OLEObjects
If oObj.TopLeftCell.Address <> chK.TopLeftCell.Address Then
If oObj.TopLeftCell.Row = chK.TopLeftCell.Row Then
boolStopEvents = True
oObj.Object.Value = IIf(boolVal = 0, True, False): iCount = iCount + 1
boolStopEvents = False
If iCount = 2 Then Exit Sub
End If
End If
Next
End If
End Sub
For case of Form check boxes type:
a). Manually assign the first sub to all your Form Type check boxes (right click - Assign Macro, choose CheckUnCheckRow and press OK).
b). Automatically assign the macro:
Dim sh As Worksheet, s As CheckBox
Set sh = ActiveSheet ' use here your sheet keeping the check boxes
For Each s In sh.CheckBoxes
s.OnAction = "'" & ThisWorkbook.Name & "'!CheckUnCheckRow"
Next
End Sub
If your check boxes have already assigned a macro, adapt CheckUnCheckRow, in Form check boxes section, to also call that macro...
For case of ActiveX check boxes:
a). Create a Public variable on top of a standard module (in the declarations area):
Public boolStopEvents
b). Manually adapt all your ActiveX check boxes Click or Change event, like in the next example:
Private Sub CheckBox1_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox1"
End Sub
Private Sub CheckBox2_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox2"
End Sub
Private Sub CheckBox3_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox3"
End Sub
and so on...
c). Or do all that with a click, using the next piece of code:
Sub createEventsAllActiveXCB()
Dim sh As Worksheet, oObj As OLEObject, strCode As String, ButName As String
Set sh = ActiveSheet 'use here your sheet keeping ActveX check boxes
For Each oObj In sh.OLEObjects
If TypeName(oObj.Object) = "CheckBox" Then
ButName = oObj.Name
strCode = "Private Sub " & ButName & "_Click()" & vbCrLf & _
" If Not boolStopEvents Then CheckUnCheckRow """ & ButName & """" & vbCrLf & _
"End Sub"
addClickEventsActiveXChkB sh, strCode
End If
Next
End Sub
Anyhow, the code cam be simplified in order to deal with only a type of such check boxes. If you intend to use it and looks too bushy, I can adapt it only for the type you like. Like it is, the code deals with both check box types, if both exist on the sheet...
Save the workbook and start playing with the check boxes. But, when you talk about check boxes on a row, all tree of them must have the same TopLeftCell.Row...

Application.CommandBars("vbaPopup").ShowPopup ··· how can I add `Submenu` (Ron de Bruin)?

I have Microsoft Office 365 2019.
First of all i want to tell how code works:
Insert Note.
Click on Cell who has inserted Note.
Press Ctrl+N
Then you will see "PopUp-Menu".
I have VBA code (to work put in ThisWorkbook):
Private Sub Workbook_Open()
Application.OnKey "^{n}", CodeName & ".ContextMenu"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "^{n}"
End Sub
Private Sub ContextMenu()
If ActiveCell Is Nothing Then Exit Sub
If ActiveCell.Comment Is Nothing Then Exit Sub
On Error Resume Next 'Can be and without inadequate to, but then with brute force(cycle) CommandBars.
Dim cb As CommandBar
Set cb = Application.CommandBars("vbaPopup")
If cb Is Nothing Then CreateContextMenu
Application.CommandBars("vbaPopup").ShowPopup
End Sub
Private Sub CreateContextMenu()
Dim a1_icon, a1_file, a2, a3, i&, m$, p$, f$: m = CodeName & ".": p = Path & "\Image\"
a1_icon = Array(76, 72, 178, 53)
a1_file = Array("NoteZoom_200x110.jpg", "NoteZoom_600x400.jpg", "Full Screen.jpg", "NoteZoom_InputBox.jpg", "Copy Text.jpg")
a2 = Array("NoteZoom 200x110", "NoteZoom 600x400", "Note <Full Screen>", "NoteZoom InputBox", "Скопировать текст примечания")
a3 = Array("NoteZoom1", "NoteZoom2", "NoteZoom3", "NoteZoom_InputBox", "NoteTextToClipboard")
With Application.CommandBars.Add("vbaPopup", msoBarPopup, , True) 'You can also not do to make the context menu temporary.
For i = 0 To UBound(a1_file) 'Ubound(a1_ico)
With .Controls.Add
f = p & a1_file(i)
If Len(Dir(f)) Then
.Picture = LoadPicture(f)
Else
.FaceId = a1_icon(i) 'If the file is not found, the icon. But it's not necessary.
End If
.Caption = a2(i)
.OnAction = m & a3(i)
End With
Next
End With
End Sub
Private Sub NoteZoom1(): NoteChangeSize 200, 110: End Sub
Private Sub NoteZoom2(): NoteChangeSize 600, 400: End Sub
Private Sub NoteZoom3()
With ActiveWindow.VisibleRange
NoteChangeSize .Width, .Height, True
'With .Resize(.Rows.Count - 1, .Columns.Count - 1) 'Without check
' NoteChangeSize .Width, .Height, True
'End With
End With
End Sub
Private Sub NoteChangeSize(w!, h!, Optional scr As Boolean)
With ActiveCell.Comment.Shape
.Width = w: .Height = h
If scr Then .Top = 0: .Left = 0: .Visible = msoTrue
End With
End Sub
'To create a `Note` with `InputBox`.
Private Sub NoteZoom_InputBox()
'Ниже 2 строчки для проверки наличия `Примечания`.
If ActiveCell Is Nothing Then Exit Sub
If ActiveCell.Comment Is Nothing Then Exit Sub
Dim lH As Long 'height
Dim lW As Long 'width
lH = Application.InputBox("Choose the HEIGHT of the notes ")
lW = Application.InputBox("Choose the WIDTH of the notes ")
With ActiveCell.Comment
' .Text Text:="Note:" & Chr(10) & ""
.Shape.Height = lH
.Shape.Width = lW
End With
End Sub
Private Sub NoteTextToClipboard()
With New DataObject
.SetText ActiveCell.Comment.Text
.PutInClipboard
End With
End Sub
For more details you can download my Excel Workbook to see how it's implemented!
Also i find code on this site Ron de Bruin. I wish to add "Submenu" in my "Menu"! Wrote out only those codes which can help to create "Submenu". But how to combine I don't know!?
Dim MenuItem As CommandBarPopup
'Add PopUp menu
With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
MenuBar:=False, Temporary:=True)
'Add menu with two buttons
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.Caption = "My Special Menu"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1 in menu"
.FaceId = 71
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
End With
In the end I want to get this:
0Key finally i find some solution for this. Right now it's looks like this:
Looks cool right? Download full code link.

Data Validation Input Message workaround 255 char

I am trying to create a workaround for the Data Validation Input Message, since my input message is more than 255 chars.
I have tried http://contextures.com/xlDataVal12.html but the text box is fixed. I would need the text box or label to move with the selected cell.
On the image below, you can see the issue. We cannot display the whole message within the input box.
1 http://img5013.photobox.co.uk/42779160c8143d2fcab8c396d411e8b621181c1be9f1a01fb62e272d26debaf4b53f7657.jpg
Using the Contextures code, you need to set the .Top and .Left properties of the shape to the same properties of a cell. Here's a rewrite of that code that moves the textbox near the cell.
' Developed by Contextures Inc.
' www.contextures.com
' modified by Dick Kusleika 7/21/2015
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sTitle As String
Dim sMsg As String
Dim sMsgAdd As String
Dim tbxTemp As Shape
Dim lDVType As Long
Dim lRowMsg As Long
Dim ws As Worksheet
Application.EnableEvents = False
Set ws = Target.Parent
Set tbxTemp = ws.Shapes("txtInputMsg")
On Error Resume Next
lDVType = 0
lDVType = Target.Validation.Type
On Error GoTo errHandler
If lDVType = 0 Then
tbxTemp.TextFrame.Characters.Text = vbNullString
tbxTemp.Visible = msoFalse
Else
If Len(Target.Validation.InputTitle) > 0 Or Len(Target.Validation.InputMessage) > 0 Then
sTitle = Target.Validation.InputTitle & vbLf
On Error Resume Next
lRowMsg = 0
lRowMsg = Application.WorksheetFunction.Match(Target.Validation.InputTitle, Sheets("MsgText").Columns(1), 0)
If lRowMsg > 0 Then
sMsgAdd = Me.Parent.Sheets("MsgText").Cells(lRowMsg, 2).Value
End If
On Error GoTo errHandler
sMsg = Target.Validation.InputMessage
With tbxTemp.TextFrame
.Characters.Text = sTitle & sMsg & vbLf & sMsgAdd
.Characters.Font.Bold = False
.Characters(1, Len(sTitle)).Font.Bold = True
End With
tbxTemp.Top = Target.Offset(1, 1).Top
tbxTemp.Left = Target.Offset(1, 1).Left
tbxTemp.Visible = msoTrue
tbxTemp.ZOrder msoBringToFront
Else
tbxTemp.TextFrame.Characters.Text = vbNullString
tbxTemp.Visible = msoFalse
End If
End If
errHandler:
Application.EnableEvents = True
End Sub

Resources