I'm writing a multi-purpose code in ThisOutlookSession, one part of the code has the job to get activated by PropertyChange in CurrentItem and if Subject is equal to a specific value, it first opens a MsgBox, on VBYes it Copies a value that is stored inside a .txt file and opens a mail with an .HTMLBody with that value.
It works fine if in the MsgBox input you answer VbYes, but if you answer VbNo then the PropertyChange is activated 3 times, in this case I have to answer 3 times VbNo.
I can actually see that the appearence of the MsgBox triggers the m_inspector_activate() which makes the code think that the Subject changed another time (this is how I think it works).
I will leave a shortened part of the code to let you see what I'am talking about.
Please text me if you do not understand something.
Option Explicit
'global variable used to disable the trigger of oItem_Forward(), oItem_Reply() and oItem_ReplyAll() while myItem_PropertyChange() is working
Public disableevents As Boolean
'private variables used to display mailitem on Reply, ReplyAll or Forward
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
'private variables used ad inspectors in PropertyChange and ItemSend
Private WithEvents m_Inspectors As Outlook.Inspectors
Private WithEvents m_Inspector As Outlook.Inspector
Private WithEvents myItem As Outlook.MailItem
'declaration necessary to manage the forwards, replies and replyall events, recognizes the discard
Private bDiscardEvents As Boolean
'declaration of variable that manages the forwards, replies and replyall events
Dim exception As MailItem
'sub activated by opening outlook, it sets the inspectors
Private Sub Application_Startup()
Set oExpl = Application.ActiveExplorer
Set m_Inspectors = Application.Inspectors
bDiscardEvents = False
End Sub
'sub that on change of item selection, sets and stores the value of oItem variable to later open the forward, reply or replyall
Private Sub oExpl_SelectionChange()
' the on error avoids the error in case the item is not mailitem
On Error Resume Next
Set oItem = oExpl.selection.item(1)
End Sub
'sub activated by the event of pressing "reply"
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
' disableevents variable exits sub if its true, blocks the activation if myItem_PropertyChange() is working
On Error Resume Next
If disableevents = True Then Exit Sub
Cancel = True
bDiscardEvents = True
'displays the before selected email when the button "reply" was pressed
Set exception = oItem.Reply
exception.Display
End Sub
'sub activated by the event of pressing "forward"
Private Sub oItem_Forward(ByVal Response As Object, Cancel As Boolean)
' disableevents variable exits sub if its true, blocks the activation if myItem_PropertyChange() is working
On Error Resume Next
If disableevents = True Then Exit Sub
Cancel = True
bDiscardEvents = True
'displays the before selected email when the button "forward" was pressed
Set exception = oItem.Forward
exception.Display
End Sub
'sub activated by the event of pressing "replyall"
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
' disableevents variable exits sub if its true, blocks the activation if myItem_PropertyChange() is working
On Error Resume Next
If disableevents = True Then Exit Sub
Cancel = True
bDiscardEvents = True
'displays the before selected email when the button "replyall" was pressed
Set exception = oItem.ReplyAll
exception.Display
End Sub
' on NewInspector it sets the inspectors variables
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
'Handle emails only:
Set oExpl = Application.ActiveExplorer
Set m_Inspector = Inspector
bDiscardEvents = False
End If
End Sub
'on m_Inspector activation the subs sets myItem variable
Private Sub m_Inspector_Activate()
If TypeOf m_Inspector.CurrentItem Is MailItem Then
Set myItem = m_Inspector.CurrentItem
End If
End Sub
'on myItem Property Change sub starts, this subs checks for subject, if subject is equal to a specific value then opens a mail using a .txt file(with html code inside) to use it as a template
Private Sub myItem_PropertyChange(ByVal Name As String)
'variables necessary to pull data from .txt file and then put it inside .HTMLBody
Dim FilePath As String
Dim TextFile As Integer
Dim FileContent As String
'inspector, explorer and mailitem used to check for subject, open selected mail and then open the "template"
Dim exp As Explorer
Dim ite As Inspector
Dim selection As selection
Dim currentmail As MailItem
Dim selectedmail As MailItem
'active part of the code where we set the various explorer, inspector and mailitems
Set exp = Outlook.ActiveExplorer
Set ite = Outlook.ActiveInspector
On Error Resume Next
Set currentmail = ite.CurrentItem
Set selection = exp.selection
On Error Resume Next
Set selectedmail = selection.item(1)
'variable that lowercases the current item subject to make it non-case sensitive
Dim lsubject As String
lsubject = LCase(myItem.Subject)
'variable that gets user's username
Dim varia As String
varia = Environ("username")
'if cycle that checks first for ConversationIndex (to control if this is a NewMail) and if lsubject (lowercase subject) is equal to a value then opens the "template"
If Len(currentmail.ConversationIndex) = 0 Then
If lsubject = "reso" Then
If MsgBox("Vuoi aprire il template ""Reso merce non conforme""?", vbYesNo) = vbYes Then
disableevents = True
FilePath = "INSERT YOUR PATH"
TextFile = FreeFile
Open FilePath For Input As TextFile
FileContent = Input(LOF(TextFile), TextFile)
Close TextFile
currentmail.Close False
Set it = Application.CreateItem(olMailItem)
With it
.To = currentmail.To
.CC = currentmail.CC
.HTMLBody = FileContent
.Display
End With
disableevents = False
Else
GoTo endvb
End if
End If
ElseIf Len(currentmail.ConversationIndex) <> 0 Then
If lsubject = "reso" Then
If MsgBox("Vuoi aprire il template ""Reso merce non conforme""?", vbYesNo) = vbYes Then
disableevents = True
FilePath = "INSERT YOUR PATH"
TextFile = FreeFile
Open FilePath For Input As TextFile
FileContent = Input(LOF(TextFile), TextFile)
Close TextFile
currentmail.Close False
selectedmail.Display
Set it = selectedmail.ReplyAll
With it
.To = selectedmail.To
.CC = selectedmail.CC
.HTMLBody = FileContent & it.HTMLBody
.Display
End With
disableevents = False
Else
GoTo endvb
End If
End If
End If
endvb:
End Sub
Function GetCurrentItem() As Object
'function that recognizes if email is open (active inspector) or if email is only selected and previewed (explorer)
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.selection.item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
'declaration of inspector and mail item
Dim ispettore As Outlook.Inspector
Dim mails As MailItem
'APIs to recognize the presence of attachments
Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
'variables for the attachment
Dim itemcorr As Outlook.MailItem
Dim miallegati As Outlook.Attachments
' setting the activeinspector and using the function Getcurrenitem() to choose for inspector or explorer, I use the error to avoid the errors generated from appointment items
Set ispettore = Application.ActiveInspector
On Error Resume Next
Set mails = GetCurrentItem()
On Error Resume Next
'variables that make possible the non case sensitive search in the HTMLBody of the email, the UpperCase stores the HTMLBody and the LowerCase makes the first variable lowercase
Dim UpperCase As String, LowerCase As String
On Error Resume Next
UpperCase = mails.HTMLBody
On Error Resume Next
LowerCase = LCase(UpperCase)
On Error Resume Next
Dim it As Variant
On Error Resume Next
'variables needed to check only the first email and not the previously sent ones
Dim testo As String
Dim range As String
Dim numero As String
Dim textcheck As String
Dim rangealt As String
Dim textcheckalt As String
Dim numeroalt As String
Dim textcheckeng As String
Dim numeroeng As String
Dim rangeeng As String
'variable that gets user's username
Dim varia As String
varia = Environ("username")
'variable to print "allegato" or "allegati" in the msgbox
Dim msgboxvar As String
testo = mails.HTMLBody
textcheck = "<div style='border:none;border-top:solid #E1E1E1 1.0pt;padding:3.0pt 0cm 0cm 0cm'>" 'text to check when email is correctly compiled and has got the line that divide the messages
textcheckalt = "-----Messaggio originale-----" 'text to check if email is sent from phone or if not correctly compiled
textcheckeng = "-----Original Message-----" 'text to check if email is sent from phone or if not correctly compiled and is in english
numero = InStr(testo, textcheck)
numeroalt = InStr(testo, textcheckalt)
numeroeng = InStr(testo, textcheckeng)
range = Left(testo, numero)
rangealt = Left(testo, numeroalt)
rangeeng = Left(testo, numeroeng)
'variables to find the possible attachments
Dim aFound As Boolean
Dim a As Object
Set miallegati = mails.Attachments
aFound = False
'if cicle that check the presence of attachment and if yes populates the variable aFound with True value
If TypeOf item Is Outlook.MailItem Then
For Each a In item.Attachments
On Error Resume Next ' to avoid the error thrown when no items within attachments have this property
If a.PropertyAccessor.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
If Len(a.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)) > 0 And InStr(Application.ActiveInspector.CurrentItem.HTMLBody, a.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)) Then
Else
aFound = True
Exit For
End If
End If
On Error GoTo 0
Next a
'if cicle that checks the desired portion of text for the word "allegato" or "allegati"
If aFound = False And InStr(LCase(range), "allegato") > 0 Then
GoTo singular
ElseIf aFound = False And InStr(LCase(range), "allegati") > 0 Then
GoTo plural
ElseIf aFound = False And InStr(LCase(rangealt), "allegato") > 0 Then
GoTo singular
ElseIf aFound = False And InStr(LCase(rangeeng), "allegato") > 0 Then
GoTo singular
ElseIf aFound = False And InStr(LCase(rangealt), "allegati") > 0 Then
GoTo plural
ElseIf aFound = False And InStr(LCase(rangeeng), "allegati") > 0 Then
GoTo plural
ElseIf aFound = False And InStr(LCase(range), "allegato") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(range), "allegati") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(rangealt), "allegato") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(rangealt), "allegati") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(rangeeng), "allegato") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(rangeeng), "allegati") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(mails.HTMLBody), "allegato") > 0 Then
GoTo singular
ElseIf aFound = False And InStr(LCase(mails.HTMLBody), "allegati") > 0 Then
GoTo plural
Else
GoTo fine
'lines that set the variable msgboxvar for plural or singluar word in msgbox
plural: msgboxvar = "allegati"
GoTo msg
singular: msgboxvar = "allegato"
GoTo msg
'this last if checks for the whole text
LastIf: If aFound = False And InStr(LowerCase, "allegato") > 0 Or InStr(LowerCase, "allegati") > 0 Then
msgboxvar = "allegato"
'msg that signals the absence of attachments and asks if mail has to be sent, if answer is no, a word application makes it possible to attach chosen files to the email
msg: If MsgBox("Nell'email hai scritto '" & msgboxvar & "' ma non ne è presente alcuno, vuoi inviarla lo stesso?", vbYesNo) = vbNo Then
' user clicked cancel
Cancel = True
End If
End If
End If
End If
fine: End Sub
I have left the other sub that check for the attachment just to let you see if there are any conflicts.
First, the MailItem.PropertyChange event is fired when an explicit built-in property (for example, Subject) of an instance of the parent object is changed. The name of the property that was changed is passed as a parameter. So, you may check the property changed and process only changes in the Subject line.
Second, in the event handlers like Reply, Forward and etc. you trigger the event by calling corresponding methods in the code:
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
'...
Set exception = oItem.Reply
End Sub
Instead, you need to use the object passed as a parameter:
ByVal Response As Object
Third, in the NewInspector event handler the following code is used to get the inspector window:
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
'...
Set m_Inspector = Inspector
End Sub
Be aware, a new inspector instance is passed as a parameter to the event handler.
You may find the Implement a wrapper for inspectors and track item-level events in each inspector article helpful.
I have a macro in that creates a ListBox.
The first item should be selected as default.
I tried
UserForm.ListBox.Selected(0) = True
I get
How can I control the Listbox from the keyboard? I need to scroll up and down with "UP" and "DOWN" keys and if "ENTER" is pressed the selected Item should be taken.
I tried the following, but this captures every "ENTER" during the code (not only when the UserForm (ListBox) is loaded).
Public Sub Listbox_Enter()
'DO Something
End Sub
Current code:
Option Explicit
Public WithEvents GExplorer As Outlook.Explorer
Public WithEvents GMailItem As Outlook.MailItem
Public WithEvents objInspectors As Outlook.Inspectors
Public WithEvents objTask As Outlook.TaskItem
'Start Outlook
Private Sub Application_Startup()
Set GExplorer = Outlook.Application.ActiveExplorer
Set objInspectors = Outlook.Application.Inspectors
End Sub
'Capture every change, but on same ActiveExplorer (Window)
Private Sub GExplorer_SelectionChange()
Dim xItem As Object
On Error Resume Next
Set xItem = GExplorer.Selection.Item(1)
If xItem.Class <> olMail Then Exit Sub
Set GMailItem = xItem
End Sub
'Reply pressed
Private Sub GMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
'ReplyAll pressed
Private Sub GMailItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
'Forward pressed
Private Sub GMailItem_Forward(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
Sub AutoAddGreetingtoReply(Item As Object)
Dim xGreetStr As String: Dim xReplyMail As MailItem
Dim xSenderName As String: Dim lSpace As Long
Dim xRecipient As Recipient: Dim obj As Outlook.MailItem
Dim EmailAdress As String: Dim EmailNameBeforeAtIkon As String:
Dim c As ContactItem
Dim names As String
On Error Resume Next:
Set obj = Outlook.ActiveExplorer.Selection.Item(1)
'This part finds the receipients
If Item.Class <> olMail Then Exit Sub 'Quits if no email is chosen
Set xReplyMail = Item
For Each xRecipient In xReplyMail.Recipients
If xSenderName = "" Then
xSenderName = xRecipient.name
Else
xSenderName = xSenderName & ", " & xRecipient.name
End If
Next xRecipient
Dim lSpace_f As Variant
Dim stFirstNAme As String
Dim st_FirstName As String
Dim currentNAme As String
lSpace_f = InStr(1, xSenderName, " ", vbTextCompare)
If lSpace_f > 0 Then
stFirstNAme = Trim(Split(xSenderName, ",")(1))
st_FirstName = Split(stFirstNAme, " ")(0)
currentNAme = st_FirstName + ","
End If
'Writes a greeting
With UserForm1.Listbox_Auswahl
.AddItem "Hello " + currentNAme
.AddItem "Good morning " + currentNAme
End With
UserForm1.Caption = ("Greeting")
Load UserForm1
UserForm1.StartUpPosition = 2
UserForm1.Show
'Creates the email
With xReplyMail
.Display
.HTMLBody = "<HTML><Body><span style=""color:#0e4a80"">" + markierterEintrag + "</span style=""color:#0e4a80""></HTML></Body>" & .HTMLBody
Sendkeys "{DOWN}", True
Sendkeys "{ENTER}", True
Call Sendkeys("", False)
.Close olSave
End With
End Sub
Public Sub Sendkeys(text As Variant, Optional wait As Boolean = False)
Dim WshShell As Object
Set WshShell = CreateObject("wscript.shell")
WshShell.Sendkeys CStr(text), wait
Set WshShell = Nothing
End Sub
'-------------------------------------
Public Sub Listbox_Auswahl_Click()
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
End If
Unload UserForm1
End Sub
'Public Sub Listbox_Auswahl_Enter()
' If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
' markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
' End If
'
' Unload UserForm1
'End Sub
This worked for me:
Public Sub Listbox_Auswahl_Click()
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
End If
End Sub
Public Sub Listbox_Auswahl_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 13 Then
With Me.Listbox_Auswahl
If .ListIndex > -1 Then
markierterEintrag = .List(.ListIndex)
End If
End With
Unload UserForm1
End If
End Sub
Public Sub Listbox_Auswahl_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
'pressed_key_flag = 1
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
Unload UserForm1
End If
End If
End Sub
I'm assigning an Outlook task via Excel. As I have not saved a copy of the task an alert shows saying that the task won't be saved and asking if I want to send it anyway.
I've been using Sendkeys (I know, it's not a good way). It's working on my computer but not on the computers of some of my colleagues.
Would it be possible to deactivate those alerts?
Here is my code:
Sub SendMail(dest As String, Echeance As String)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i As Integer
Dim nom As String
Dim compte As Integer
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.TaskItem
Dim myDelegate As Outlook.Recipient
Set myOlApp = New Outlook.Application
For i = 1 To myOlApp.Session.Folders.Count
If myOlApp.Session.Folders.Item(i) = "_F_VTG-LBA ALCG-RAVEVAC" Then
compte = i
Exit For
End If
Next i
Set myItem = myOlApp.Session.Folders.Item(compte).Items.Add(olTaskItem)
myItem.Assign
Set myDelegate = myItem.Recipients.Add(dest)
myDelegate.Resolve
If myDelegate.Resolved Then
myItem.Subject = Task.titre
myItem.Body = Task.Mess
myItem.DueDate = Echeance
myItem.StartDate = Now
myItem.ReminderTime = True 'Rappel
myItem.Display
Application.DisplayAlerts = False
myItem.Send
'Or
Application.Wait (Now + TimeValue("0:00:03"))
Application.SendKeys "^~" 'presses send as a send key
Application.Wait (Now + TimeValue("0:00:03"))
SendKeys "TAB", True
SendKeys "{ENTER}", True
i = 0
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
If you do not want the task in your own list then assign the normal way then delete.
myItem.Display ' Do not uncheck the box
myItem.Send
myItem.Delete
I have the following code that builds a custom menu in Excel. Works well. I'm trying to modify it to use sub menus. It will add the menu item for East Options and West Options. I'm trying to modify the East and West # 1 items so they appear as a sub menu. I've tried a number of different things but I haven't got the syntax right. Any help would be appreciated. Thanks.........
Dim cbWsMenuBar As CommandBar
Dim TrCustom As CommandBarControl
Dim iHelpIndex As Long
Dim vFoundMenu As Boolean
Set cbWsMenuBar = Application.CommandBars("Worksheet Menu Bar")
cbWsMenuBar.Visible = True
Dim CCnt As Long
For CCnt = 1 To cbWsMenuBar.Controls.Count
If InStr(1, cbWsMenuBar.Controls(CCnt).Caption, "Translate") > 0 Then vFoundMenu = True
Next CCnt
If vFoundMenu = False Then
Set TrCustom = cbWsMenuBar.Controls.Add(Type:=msoControlPopup) ', before:=iHelpIndex)
With TrCustom
.Caption = "Menu Items”
With .Controls.Add(Type:=msoControlButton)
.Caption = "Business Unit to Group"
.OnAction = "ShowBU2GP"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Group to Business Unit"
.OnAction = "ShowGP2BU"
End With
With .Controls.Add(Type:=msoControlPopup)
.Caption = "East Region Options"
End With
‘ EAST # 1
' With .Controls.Add(Type:=msoControlButton)
' .Caption = "East Branch to DeptID"
' .OnAction = "ShowEastDeptID"
' .BeginGroup = True
' End With
With .Controls.Add(Type:=msoControlPopup)
.Caption = "West Options"
End With
' WEST # 1
' With .Controls.Add(Type:=msoControlButton)
' .Caption = "West Branch to DeptID"
' .OnAction = "ShowWestDeptID"
' .BeginGroup = True
' End With
End With
End If
I will show you a very simple example. Please amend it to suit your needs :)
Private Sub Sample()
Dim cb As CommandBar
Dim cbc As CommandBarControl
Dim newitem As CommandBarControl
Dim newSubItem As CommandBarControl
Set cb = Application.CommandBars(1)
'~~> Delete Existing command bar control
On Error Resume Next
cb.Controls("Menu Items").Delete
On Error GoTo 0
'~~> Re Create the Command Bar Control
Set cbc = cb.Controls.Add(Type:=msoControlPopup, temporary:=False)
With cbc
'~~> Main Heading
.Caption = "Menu Items"
'~~> First Sub Heading
Set newitem = .Controls.Add(Type:=msoControlPopup)
With newitem
.BeginGroup = True
.Caption = "East Region Options"
Set newSubItem = .Controls.Add(Type:=msoControlButton)
With newSubItem
.BeginGroup = True
'~~> Sub Item
.Caption = "Sub Item for East Region Options"
.Style = msoButtonCaption
.OnAction = "SomeMacro"
End With
End With
'~~> Second Sub Heading
Set newitem = .Controls.Add(Type:=msoControlPopup)
With newitem
.BeginGroup = True
.Caption = "West Region Options"
Set newSubItem = .Controls.Add(Type:=msoControlButton)
With newSubItem
.BeginGroup = True
'~~> Sub Item
.Caption = "Sub Item for Est Region Options"
.Style = msoButtonCaption
.OnAction = "SomeMacro"
End With
End With
'
'~~> And So On
'
End With
End Sub
Screenshot
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
'====================================