I have a macro that creates a command button however I am unable to assign any macro to the button in the VBA
have looked at this link but its for a userform (but I'm not good enough to be able to change it to suit what I need)
The code I am currently tring is below, I'm guessing I need to add something to the With Statement but I dont know what it would be
Dim MyR As Range, MyB As OLEObject
Dim MyR_T As Long, MyR_L As Long
Set MyR = Range("I3") 'just an example - you get that from your own script
MyR_T = MyR.Top 'capture positions
MyR_L = MyR.Left '...
'create button
Set MyB = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False)
'set main button properties
With MyB
.Name = "MyPrecodedButton" 'important - code must exist ... see below
.Object.Caption = "Load UseForm"
.Top = MyR_T
.Left = MyR_L
.Width = 130
.Height = 30
.Placement = xlMoveAndSize
.PrintObject = True 'or false as per your taste
End With
So from your own link you have posted, your code would look like this:
Set UF = ActiveWorkbook.VBProject.VBComponents("Name_of_the_userform")
With UF.CodeModule
.InsertLines 2, _
"Private Sub " & MyB.Name & "_Click()" & Chr(13) & _
"****HERE COMES YOUR FUNCTION CALL FOR THE BUTTON****" & Chr(13) & _
"End Sub"
End With
But this only works with activeX Buttons. What it does is quite a hack... so if you have a better solution i would not recommend this one. What it does is this: Every ActiveX Button has a onclick function with the following Syntax: "ButtonName_Click()" If you somewhere in your code put this line, it will be executed on click. now what the code does (as in the link which you have posted), is it writes These functions into the userform code.
Use .onAction method
Something like this
Sheets("someVeryFunnySheetName").buttons("someSeriousButtonName").onAction = "macroName"
Here is one example, if you wana to pass parameter to that macro (axleOutputSHeetCounter is some integer i think)
With chartSheet.Buttons("closeOutputSheet")
.OnAction = "'Module7_Axle.closeOutputSheet """ & axleOutputSheetCounter & """'"
.Characters.text = "Delete sheet"
.Characters.Font.Size = 16
End With
edit: for activeX buttons here you can find question with same issue and working solution
Related
I'm trying to automate some development steps by using VBA code and want to start those macros with a shortcut key while the VBE window is active/on top. Is there a way to do this? The Macro dialog in VBE does not offer the Options button, which allows to define a shortcut key in Excel proper. I also have not found a way to solve my problem via the VBE toolbar customization.
The F5 key us the shortcut to run this. This can be viewed by hovering the pointer over the "continue" option in the toolbar so the dialog pop up displays.
You cannot define Keyboard shortcuts within the VBE.
As long as your Subroutine gets no parameter:
put the cursor inside the subroutine and press F5
put the cursor outside of any routine and press F5 - you will get a list of Subs that you can start
Enter the name of the sub in the immediate window (Ctrl+G) and press Enter
If your Subroutine expects some parameter (even if it is only optional), only the method with the immediate window works. But you can write a short wrapper routine that calls the subroutine you want to call.
Thanks for the replies on my question. I was aware of the options presented there. As it seems that no real shortcut capabilities are available in VBE, I finally used a custom menu to access the VBA code I want to start during VBE sessions. I now have access to all of them (distributed over several modules and partially with long, description like names) via one macro (I call DM = short for DeveloperMenu) I (still) need to start via the immediate window.
Code below. Of course the specific menu items are custom for my environment and need to be adapted.
Sub Dm(Optional dummy As Boolean)
Call CreateAndDisplayDevelopmentPopUpMenu
End Sub
Sub CreateAndDisplayDevelopmentPopUpMenu(Optional dummy As Boolean)
Dim menuName As String
menuName = "Development"
'Delete PopUp menu if it exist
On Error Resume Next
Application.CommandBars(menuName).Delete
On Error GoTo 0
'Create the PopUpmenu
Call DevelopmentPopUpMenu(menuName)
'Show the PopUp menu
On Error Resume Next
Application.CommandBars(menuName).ShowPopup
On Error GoTo 0
End Sub
Sub DevelopmentPopUpMenu(menuName As String)
Dim MenuItem As CommandBarPopup
'Add PopUp menu
With Application.CommandBars.Add(name:=menuName, position:=msoBarPopup, _
MenuBar:=False, Temporary:=True)
'First add buttons
With .Controls.Add(type:=msoControlButton)
.caption = "&RebuildDefs"
' .faceId = 71
.OnAction = "'" & ThisWorkbook.name & "'!" & "'RebuildAllDefs ""True""'"
End With
With .Controls.Add(type:=msoControlButton)
.caption = "&ToggleAddIn"
' .faceId = 71
.OnAction = "'" & ThisWorkbook.name & "'!" & "ToggleAddIn"
End With
'Second menues
Set MenuItem = .Controls.Add(type:=msoControlPopup)
With MenuItem
.caption = "&Watch"
With .Controls.Add(type:=msoControlButton)
.caption = "&Start watch"
' .faceId = 71
.OnAction = "'" & ThisWorkbook.name & "'!" & "startWatch"
End With
With .Controls.Add(type:=msoControlButton)
.caption = "&End watch"
' .faceId = 72
.OnAction = "'" & ThisWorkbook.name & "'!" & "DeleteAllwatches"
End With
End With
Set MenuItem = .Controls.Add(type:=msoControlPopup)
With MenuItem
.caption = "&HeartBeat"
With .Controls.Add(type:=msoControlButton)
.caption = "&Start HeartBeat"
' .faceId = 71
.OnAction = "'" & ThisWorkbook.name & "'!" & "heartBeat"
End With
With .Controls.Add(type:=msoControlButton)
.caption = "St&op HeartBeat"
' .faceId = 72
.OnAction = "'" & ThisWorkbook.name & "'!" & "stopHeartBeat"
End With
End With
End With
End Sub
TL;DR - You need to change the tools name and add an & in front of the letter you want to be the hotkey. The shortcut will now be Alt + <first letter following &>.
The above method is the only custom shortcut (a.k.a. Accelerator Key) method that is native to the VBE (if I'm not mistaken). I know this question is old, but it ranks much higher than the actual answer, so I thought I'd leave my results for the next person (which will probably be me again next year).
If you customize the VBE toolbar, you should be able to find a button labeled "Modify Selection" (you might need to click the "Rearrange Commands" button first from the Commands tab for a pop-up window with a working "Modify Selection" button if the button on the Commands tab is grayed out). On the drop-down context menu you'll see a textbox for the tool's name. This is the textbox where you add the & in front of the letter in the name that you want to use as the shortcut key. For effectively the same answer but slightly different procedure/implementation, see this answer: https://stackoverflow.com/a/23954017
I would like to do more or less as the author has intended here:
http://ccm.net/faq/1105-adding-a-vba-commandbutton-with-its-respective-the-code
unfortunately, although the code is written to the correct sheet in Microsoft Excel Objects, the code does not run once the button is pressed. The _Click() is here:
Sub ButtonTest_Click()
MsgBox "I am supposed to work!" 'but i dont, i actually do nothing
End Sub
and the rest of the code is below:
Sub CreateButton()
Dim Obj As Object
Dim Code As String
Sheets("Sheet1").Select
'create button
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, Left:=200, Top:=100, Width:=100, Height:=35)
Obj.Name = "TestButton"
'buttonn text
ActiveSheet.OLEObjects(1).Object.Caption = "Test Button"
'macro text
Code = "Sub ButtonTest_Click()" & vbCrLf
Code = Code & "Msgbox ""I am supposed to work!""" & vbCrLf
Code = Code & "End Sub"
'add macro at the end of the sheet module
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
.insertlines .CountOfLines + 1, Code
end With
End Sub
nothing happens when the button is pressed- to my mind it looks like it should fire the event as author intended, any ideas why it doesn't?
You are creating ActiveX components. Unlike form components you cannot name the underlying macros as you wish. The macros' names must start with the name of the ActiveX component followed by and underscore and the even name.
So, if your ActiveX component is named TestButton (according to this):
Obj.Name = "TestButton"
Then the sub's name to handle the click event must be named:
Sub TestButton_Click()
Hence, you'll have to rename the sub or you must change the name for the ActiveX component to match.
Alternatively, you can also implement form controls. The following three lines of code create a new form control CheckBox and assigns your macro to it (when clicked):
Dim chk As CheckBox
Set chk = ActiveSheet.CheckBoxes.Add(390.75, 216, 72, 72)
chk.OnAction = "ButtonTest_Click"
I have never used Outlook VBA (2010), but my manager tasked me to create a user form that sends IT requests and IS requests. I have the custom form created, where I gather all my text fields and print the text to a single text box.
This action is all defined within Sub CommandButton1_Click(), which ends with Send(). Within the sub, I have something like this for all text boxes:
Set Sj =Item.GetInspector.ModifiedFormPages("P.2").Controls("Subject_Text")
Set YNbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("YNBox")
Set Rbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("ReasonBox")
What I want to know is how do I take the texts within "P.2" and paste it into the Message area of "Message" Page?
Here is the code snippet for the printing out to a single text box:
FinalBox.Text = "Subject: " & Sj.Text & vbCrLf & _
vbCrLf & "Can work around the issue?: " & YNbox.Text & _
vbCrLf & "Reason For Ticketing: " & Rbox.Text & _
vbCrLf & "Department: " & Dbox.Text & _
vbCrLf & "Impact: " & Ibox.Text & _
vbCrLf & "Urgency: " & Ubox.Text & _
vbCrLf & "System/Machine Number: " & Mbox.Text & _
vbCrLf & "Was trying to accomplish: " & Abox.Text & _
vbCrLf & "Has it occured before?: " & Bbox.Text & _
vbCrLf & "First Noticed: " & Tbox.Text & _
vbCrLf & "Others affected by the issue: " & Affbox.Text & _
vbCrLf & "Additonal Comments: " & Addbox.Text
So, how do I take this and append it to the actual message field in Message page?
.
Thank you very much!!
P.S. I've been having issues with MailItem.body and whenever I create an object, for example:
Dim objMsg As Object,
I get an error that says "Expected end of statement"... I understand VB and VBA is different, but I didn't think it'd be giving me this much headache.
Edit:
Hello dbMitch and Tony Dallimore, thanks for helping me clarify my questions. Like I mentioned, I am a mere beginner when it comes to VBA, and I Just wanted to
`Sub Commandbutton
Set Sj = Item.GetInspector.ModifiedFormPages("P.2").Controls("Subject_Text")
Set YNbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("YNBox")
Set Rbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("ReasonBox")
Set Dbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("DepartmentDropbox")
Set Mbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("MachineBox")
Set Ibox = Item.GetInspector.ModifiedFormPages("P.2").Controls("ImpactBox")
Set Ubox = Item.GetInspector.ModifiedFormPages("P.2").Controls("UrgencyBox")
Set Abox = Item.GetInspector.ModifiedFormPages("P.2").Controls("AccomplishBox")
Set Bbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("BeforeText")
Set Tbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("Timebox")
Set Affbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("AffectedBox")
Set Addbox = Item.GetInspector.ModifiedFormPages("P.2").Controls("AdditionalBox")
Set Tbox8 = Item.GetInspector.ModifiedFormPages("P.2").Controls("TextBox8")
Set MESBOX = Item.GetInspector.ModifiedFormPages("Message").Controls("Message")
Tbox8.Text = "Subject: " & Sj.Text & vbCrLf & _
vbCrLf & "Can work around the issue?: " & YNbox.Text & _
vbCrLf & "Reason For Ticketing: " & Rbox.Text & _
vbCrLf & "Department: " & Dbox.Text & _
vbCrLf & "Impact: " & Ibox.Text & _
vbCrLf & "Urgency: " & Ubox.Text & _
vbCrLf & "System/Machine Number: " & Mbox.Text & _
vbCrLf & "Was trying to accomplish: " & Abox.Text & _
vbCrLf & "Has it occured before?: " & Bbox.Text & _
vbCrLf & "First Noticed: " & Tbox.Text & _
vbCrLf & "Others affected by the issue: " & Affbox.Text & _
vbCrLf & "Additonal Comments: " & Addbox.Text
Send
End Sub
`
Sub I found online that is suppose to take an item and append the text onto message body. There seems to be an error every time I try to declare the object's type (Ex. ____ As _____). I was not sure how to modify this to make it fit with my code, but the error is thrown at Dim objItem As Object that says
Expected end of statement
Sub TestAppendText()
Dim objItem As Object
Dim thisMail As Outlook.MailItem
'On Error Resume Next
Set objItem = Application.ActiveExplorer.Selection(1)
If Not objItem Is Nothing Then
If objItem.Class = olMail Then
Set thisMail = objItem
Call AppendTextToMessage(thisMail, "Some text added at " & Now())
End If
End If
Set objItem = Nothing
Set thisMail = Nothing
End Sub
Sub AppendTextToMessage(ByVal objMail As Outlook.MailItem, ByVal strText As String)
Dim objCDO As MAPI.Session
Dim objMsg As MAPI.Message
Dim objField As MAPI.Field
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
If Not objMail.EntryID = "" Then
Set objMsg = objCDO.GetMessage(objMail.EntryID, _
objMail.Parent.StoreID)
objMsg.Text = objMsg.Text & vbCrLf & strText
objMsg.Update True, True
Set objField = objMsg.Fields(CdoPR_RTF_COMPRESSED)
If Not objField Is Nothing Then
objField.Delete
objMsg.Update True, True
End If
Set objField = Nothing
Set objField = objMsg.Fields(CdoPR_RTF_SYNC_BODY_COUNT)
If Not objField Is Nothing Then
objField.Delete
objMsg.Update True, True
End If
Else
strMsg = "You must save the item before you add text. " & _
"Do you want to save the item now?"
intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Append Text to Message")
If intAns = vbYes Then
Call AppendTextToMessage(objMail, strText)
Else
Exit Sub
End If
End If
Set objMsg = Nothing
objCDO.Logoff
Set objCDO = Nothing
End Sub
I've also tried using a CDO object, but it gives me an error that says
ActiveX component can't create object: 'CDONTS.NewMail'
Set Item1 = Item.MessageClass
Set objCDONTS = CreateObject ("CDONTS.NewMail")
objCDONTS.Body = Tbox8.Text
Item1.Message = "Hi"
I apologize if this seems very simple to others.. I just have 0 experience with VBA/VBScript and Outlook designs. That's why I'm here, to learn!
Please do not ask a question like this again. I do understand the difficulty of telling one’s manager that you lack the background to tackle a task. The typical response seems to be: “It is easy: just look it up on the internet.” In one sense this is true. There is nothing in the answer below that you could not find in other answers. What you lack is the background to identify the features you require and to fit them together to create the solution. VBA is not a difficult language but it has many significant differences from other languages that will confuse an experienced programmer new to VBA. The Outlook Object model takes time to master.
There are many online Excel VBA and Outlook VBA tutorials. I think the Excel VBA tutorials are better. If you are asked to perform a similar task again, you must insist on having the time to study first. These answers of mine might help:
Update excel sheet based on outlook mail
How to copy Outlook mail message into excel using VBA or Macros
I wanted to create a complete solution since I did not believe another snippet would help. You need: “This works. Adjust it step by step to your exact requirement.”
I am not familiar with custom forms and can find nothing that says what advantage they offer over user forms which work with all versions of VBA. I did not want to take the time to study custom forms particularly as I have code for user forms that I can easily adjust to your requirement. If your custom form is working to your satisfaction, replace that part of my solution.
There are five parts to my solution:
The user form.
The first part of the subroutine SendTicket() which loads the user form and calls it to get data from the user.
The subroutine UserForm_Initialize() within the user form’s code which builds the form from parameters supplied by SendTicket().
The subroutine CommandButton1_Click() which performs minimal validation of the user’s data and stores it for SendTicket().
The second part of the subroutine SendTicket() which builds the email from the user’s data and sends it to the IT department.
1. The user form
I inserted a new user form, adjusted its size and added controls. If you do not know how to do this then look at one of the tutorials that introduce user forms.
If I add a label control to a user form and name it X, I can, for example:
Move it by changing X.Top.
Display some text by changing X.Caption.
The user form includes a Collection named Controls. A collection is what most languages call an unsorted list. Within Controls there will be an entry for every control (label, text box, command button, etc.) on the form. If the label X is the first control on the user form, I can access its properties as Controls(0).Top and Controls(0).Caption. This means I can have code specific to label X that reference it by name or I can have general code that handles all or selected labels by their position within Controls. For your requirement, I believed general code would be easier so that is what I have provided.
I created a label control and a text box control. I left the default names but changed some properties:
LABEL TEXT BOX
* Name Label1 TextBox1
Caption Prompt/Name
Font Tahoma 10 Tahoma 10
Height 12 18
Left 12 230
* Multiline True
* Scrollbars 2 - frmScrollBarsVertical
TextAlign 3 – frmTextAlighRight 1 – frmTextAlignLegt
Text/Value abcdefghijklmnopqrstuvwyz
* Visible False False
Width 200 400
* Word wrap True True
Properties starting “*” are important. The others are because I like the way they affect the form’s appearance.
In the UK, “Label1” and “TextBox1” are the default names for the first label and textbox. With Excel, default names vary with the local language; I do not know if this is true for Outlook. Within the code, it tells you how to change the default names if necessary.
My code assumes the captions for the labels will fit on a single line but the text entered into the text boxes may require several lines.
Having created my standard label and text box, I selected them, copied them, pasted them and then moved the copies so they were exactly under the first pair. I repeated this with the four controls then the eight controls and finally the sixteen controls. I ended with a column of sixteen labels and a column of sixteen text boxes. I was not concerned with the vertical position of the controls; I handle that later. If either column is not perfectly aligned, you can select a column and set the Left property for the entire group. I have created forms with hundreds of controls with acceptable performance so add more if you wish.
I created a command button. I lined it up with the text boxes but made the font larger. I retained the default name and caption.
By creating the command button last, the controls are in the correct tab order. The form opens with the cursor in the first (top) field and each tab takes the cursor to the next field and then to the button.
Finally, I set the width of the form so it was a little wider than the controls. I set the height so it was close to the screen height which on my laptop is about 560. It is possible to get the screen height from the system but that is beyond the scope of this answer. I set the caption to “Report issue”. I named it P2 which the closest I can get to your name (P.2 is an invalid name for a user form). The result was:
** 2. Part 1 of subroutine SendTicket()**
A macro cannot directly send parameters to a user form or receive values back. It must use global variables. P2Params is the global I use to pass data to the user form and I use P2Values to pass data back.
P2Params = Array("Subject", …) is the statement that loads P2Paramswith parameters. The first three parameters are "Subject", 18, True which specify the first text box. The prompt/name is “Subject”, the height is 18 and it is mandatory. Each further set of three parameters defines another text box.
I could have defined all this information within the form but getting a form like this looking the way you want can be very fussy particularly if you change your mind about the height of a text box so all the lower ones have to be moved down. With this approach you can change a text box’s height or change the sequence or add a new field with no hassle at all. Note: height defines the height allocated to the control. On my laptop and with my choice of font, 54 is enough for four lines. If the user types a fifth line, the scroll bars will appear against the relevant control so the user can see all the lines. You specify height of each text box based on some average or typical ticket but it does not matter if the user wants to enter more text than you expected.
Load P2 loads the form into memory and calls UserForm_Initialize() to initialise the form. .Show vbModal passes control to the form. Control is not returned until the user does something to return control. In this case, clicking the command button returns control providing the entered values pass the validation code.
3. The subroutine UserForm_Initialize()
I do not intend to say too much about this sub-routine. Comments within the code fully explain what the code does and the image below shows the result:
If you look down the parameters in P2Params. You can see where this layout came from. The beauty of this approach is that with a different set of parameters, a very different form can be produced. A requirement to import a list of text values is not uncommon so I have used variations of this code before and will again.
4. The subroutine CommandButton1_Click()
The user can enter values into the text boxes in required. Once they are correct, the user clicks the command button which was been re-captioned “Send” by the first part of subroutine SendTicket().
This routine validates that all mandatory fields have a value. I have implemented permitted ranges and other validation but this is sufficient for your requirement. If the field values are acceptable, the routine loads the entered values into array P2Values. As I said, only by storing values in a global variable can a user form return values to the caller.
5. The second part of the subroutine SendTicket()
This code takes the values from P2Values builds the email and sends it. I have send emails to an experimental Gmail account. You will need to replace the recipient with the address of your IT Department.
Summary
There is a lot here for you to think about. Work through it slower and come back with questions if necessary
SendTicket()
Option Explicit
Public Type FieldDtl
CtrlLabel As Long
CtrlTextBox As Long
Height As Long
Mandatory As Boolean
Prompt As String
End Type
Public P2Params As Variant
Public P2Values() As String
Sub SendTicket()
Dim InxFld As Long
Dim InxPrm As Long
Dim MailItemCrnt As MailItem
P2Params = Array("Subject", 18, True, _
"Can you work around the issue?", 18, True, _
"Reason For Ticketing", 30, True, _
"Department", 18, False, _
"Impact", 18, True, _
"Urgency", 18, True, _
"System/Machine Number", 18, True, _
"Was trying to accomplish", 54, True, _
"Has it occured before?", 18, True, _
"First Noticed", 18, False, _
"Others affected by the issue", 42, True, _
"Additional Comments", 54, True)
' Used to test total height of control exceeding height of screen
'P2Params = Array("Subject", 50, True, _
' "Can you work around the issue?", 50, True, _
' "Reason For Ticketing", 50, True, _
' "Department", 50, False, _
' "Impact", 50, True, _
' "Urgency", 50, True, _
' "System/Machine Number", 50, True, _
' "Was trying to accomplish", 54, True, _
' "Has it occured before?", 50, True, _
' "First Noticed", 50, False, _
' "Others affected by the issue", 54, True, _
' "Additional Comments", 54, True)
Load P2
With P2
.CommandButton1.Caption = "Send"
.Show vbModal
End With
' The bounds of P2Values are 1 to number of fields
' The bounds of P2Params could be 1 to NumberOfFields*3 but is almost
' certainly 0 to NumberOfFields*3-1
Set MailItemCrnt = CreateItem(olMailItem)
With MailItemCrnt
.BodyFormat = olFormatPlain
.Recipients.Add "AbbeyRuins33#gmail.com"
.Subject = P2Values(1) ' Assumes subject is first field
.Body = P2Params(LBound(P2Params) + 3) & ": " & P2Values(2)
InxFld = 3
For InxPrm = LBound(P2Params) + 6 To UBound(P2Params) Step 3
.Body = .Body & vbCrLf & P2Params(InxPrm) & ": " & P2Values(InxFld)
InxFld = InxFld + 1
Next
.Display
' .Send
End With
Set MailItemCrnt = Nothing
End Sub
Code for user form
Option Explicit
' In UK, the default name for a label is "LabelN" and the default name for a text box
' is "TextBoxN". In case the default name is different is non-English speaking
' countries, I use constants for these values. Change the value of these constants
' as necessary.
Const NameLabel As String = "Label"
Const NameTextBox As String = "TextBox"
' This code assumes there are N labels named NameLabel & 1 to NameLabel & N and
' N text boxes named NameTextBox & 1 to NameTextBox & N. NameLabelX is used to
' label TextBoxX which is used to obtain the Xth value from the user.
' User type FieldDtl is defined in the SendTicket module
Dim Fields() As FieldDtl
Private Sub CommandButton1_Click()
Dim ErrMsg As String
Dim InxFld As Long
' Check values have been entered for mandatory fields
ErrMsg = ""
For InxFld = 1 To UBound(Fields)
If Fields(InxFld).Mandatory And Controls(Fields(InxFld).CtrlTextBox).Text = "" Then
If ErrMsg <> "" Then
ErrMsg = ErrMsg & vbLf
End If
ErrMsg = ErrMsg & "Please enter a value for " & Fields(InxFld).Prompt
End If
Next
' No value entered for one or more mandatory fields
If ErrMsg <> "" Then
Call MsgBox(ErrMsg, vbOKOnly)
Exit Sub
End If
' Save values for caller
ReDim P2Values(1 To UBound(Fields))
For InxFld = 1 To UBound(Fields)
P2Values(InxFld) = Controls(Fields(InxFld).CtrlTextBox).Text
Next
Unload Me
End Sub
Private Sub UserForm_Initialize()
Const GapBetweenCtrls As Long = 5
Dim InxCtrl As Long
Dim InxFld As Long
Dim InxPrm As Long
Dim NumFields As Long
Dim NumParams As Long
Dim TopNext As Long
' Note: LBound(P2Params) can be zero or one but will almost certainly be zero.
' This code allows for either possibility.
NumParams = UBound(P2Params) - LBound(P2Params) + 1
Debug.Assert NumParams Mod 3 = 0
NumFields = NumParams / 3
ReDim Fields(1 To NumFields)
' Import values from P2Params
' P2Params must contain 3N paramerers where N is the number of values
' to be obtained from the user. The three values are:
' Prompt/Name for value.
' Height of value (so control can be sized for multi-line values).
' Mandatory? (True is a value must be entered)
InxFld = 1
For InxPrm = LBound(P2Params) To UBound(P2Params) Step 3
Fields(InxFld).Prompt = P2Params(InxPrm)
Fields(InxFld).Height = P2Params(InxPrm + 1)
Fields(InxFld).Mandatory = P2Params(InxPrm + 2)
InxFld = InxFld + 1
Next
' Controls can be accessed by name (for example Label1.Caption) or
' by position within the collection Controls (for example
' Controls(1).Caption). Add control numbers to Fields().
For InxCtrl = 0 To Controls.Count - 1
If Left$(Controls(InxCtrl).Name, Len(NameLabel)) = NameLabel Then
' Extract number at end of name
InxFld = CLng(Mid(Controls(InxCtrl).Name, Len(NameLabel) + 1))
If InxFld <= NumFields Then
' This control will be used
Fields(InxFld).CtrlLabel = InxCtrl
End If
ElseIf Left$(Controls(InxCtrl).Name, Len(NameTextBox)) = NameTextBox Then
InxFld = CLng(Mid(Controls(InxCtrl).Name, Len(NameTextBox) + 1))
If InxFld <= NumFields Then
' This control will be used
Fields(InxFld).CtrlTextBox = InxCtrl
End If
End If
Next
' For InxFld = 1 To NumFields
' Debug.Print Fields(InxFld).Name & " " & Fields(InxFld).Height & " " & _
' Fields(InxFld).Mandatory & " " & Fields(InxFld).CtrlLabel & _
' " " & Fields(InxFld).CtrlTextBox
' Next
' Now have information necessary to build form.
' This code assumes/relies on:
' * All properties of the textbox controls being correct
' except for Top and Height.
' * All properties of the label controls being correct except for Top.
' * The Height of the label controls being less than the Height of any
' Textbox control.
' * The Visible property of the label and textbox controls being false.
' * The Multiline property of the textbox controls being true
' * The Scrollbars property of the textbox controls being
' 2 = frmScrollBarsVertical
' * The Width of the label property being such that all captions fit.
TopNext = GapBetweenCtrls
For InxFld = 1 To NumFields
With Controls(Fields(InxFld).CtrlLabel)
.Top = TopNext
.Caption = Fields(InxFld).Prompt
.Visible = True
End With
With Controls(Fields(InxFld).CtrlTextBox)
.Top = TopNext
.Height = Fields(InxFld).Height
.Text = ""
.Visible = True
End With
TopNext = TopNext + Fields(InxFld).Height + GapBetweenCtrls
Next
With CommandButton1
.Top = TopNext
TopNext = TopNext + .Height + GapBetweenCtrls
End With
' Set scroll height so if total height of controls exceeds height
' of form, user can scroll from top to bottom.
ScrollHeight = TopNext
End Sub
I wish to create a Treeview with images and data from a worksheet (each line has the name of a part, its next up assembly and an icon all populated by the user). I've finally managed to get the treeview to populate correctly and to include images from an external source (based on code from various sources and just a little of my own).
Setting up the Imagelist and assigning it to the Treeview is still a mystery to me but it works.
What is missing is getting the pictures from inside the worksheet and into the Imagelist instead of from an outside source ((using iml.ListImages.Add 1, "img1", LoadPicture("C:\Temp\red.jpg") ).
I read dozens of posts about it to no avail, and there is one that is mentioned in several places but is a deadend. The one other alternative I've read about involves copying the picture to the clipboard and pasting elsewhere but it involves a lot of code and seemed beyond my capability, so I haven't tried it yet.
I can "read" the pictures properties from the worksheet using Sheet1.Shapes(1) or similar with .Type (which results in "13") or .Name (which returns "Picture 1" for example) or .TopLeftCell.Address (which returns "$C$1" for example) etc. So I know I have access to them and am referencing the correct objects.
When I try to use iml.ListImages.Add 1, "img1", Sheet1.Shapes(1) I get a "Invalid Picture" error.
When I try to use iml.ListImages.Add 1, "img1", Sheet1.Shapes(1).Picture I get a "Object doesn't support this property or method" error.
When I try to use iml.ListImages.Add 1, "img1", Sheet1.Shapes(1).CopyPicture I get a "Type Mismatch" error.
I don't know what else to try and where else to look. Please help.
EDIT:
All this happens within a userform.
Are you using a UserForm? If so here is a suggestion or more of a workaround to your issue.
Why have the images in your worksheet to then try and load them in the form? Maybe try having them in the UserForm in the first place, here is how.
Create a frame on your userform:
Frame http://im88.gulfup.com/Moy8I6.png
Set the visible property of the frame to "False":
Visible http://im88.gulfup.com/sAIQqh.png
Insert your images by adding a picture control and loading the images, you can add as many images as you need:
Images http://im88.gulfup.com/oas0EQ.png
Name the images:
Name http://im88.gulfup.com/cIO317.png
Drag all the images one over the other into the frame, (you can then move the frame into a corner so it doesn't bother you:
Drag http://im88.gulfup.com/1fOSut.png
Move Away http://im88.gulfup.com/Q1fzKd.png
Next create a picture control, this is what you will use to display the picture based on a selection:
Form View http://im88.gulfup.com/X1UVRB.png
In this example, I am going to use a combobox for the selection. Now insert the below code in to the form which is pretty straight forward:
Private Sub ComboBox1_Change()
' Image1 is the name of the created picture control
UserForm3.Controls.Item("Image1").Picture = UserForm3.Controls.Item(UserForm3.ComboBox1.Value).Picture
End Sub
Private Sub UserForm_Initialize()
UserForm3.ComboBox1.AddItem "Argentina"
UserForm3.ComboBox1.AddItem "Brazil"
UserForm3.ComboBox1.AddItem "Chile"
End Sub
As you will see, the frame with the pictures is Hidden, and the image is changing inside the picture control based on a selection:
Result http://im88.gulfup.com/MSqyHF.png
I think it's the better way to go as opposed to exporting the images from the worksheet to a Temp folder and then loading them back into the picture controls.
#SiddhartRout provided the alternative that worked in a comment above: "Stephen Bullen's PastePicture code" as shown HERE. It's the only alternative I found that would not require going outside the file and it worked fine (on a sample file; still pending testing on a bigger example).
Thank you all for the help.
I would like to upload the file with the code etc. but I don't know how to do it, so I'm pasting the part of the "heart" of the code. There are two more modules: one to call the userform and Stephen Bullen's module. The code below is added to the userform itself, and it contains the treeview, the "OK" button and two images called "RED" and "GREEN" which are just small square jpgs of the respective color. I hope this helps.
' based on macros written 19991217 by Ole P. Erlandsen, ope#erlandsendata.no
Option Explicit
Private Sub CommandButton1_Click()
Dim i As Integer, strNodes As String, lngSelCount As Long
Me.Hide
lngSelCount = 0
strNodes = "Checked Items" & Chr(13) & "Index, Key, Text:" & Chr(13)
For i = 1 To TreeView1.Nodes.Count
With TreeView1.Nodes(i)
If .Checked Then
strNodes = strNodes & .Index & "; " & .Key & "; " & .Text & "; " & .Image & Chr(13)
lngSelCount = lngSelCount + 1
End If
End With
Next i
strNodes = strNodes & Chr(13) & "Count of Checked Items: " & lngSelCount
strNodes = strNodes & Chr(13) & Chr(13) & _
"Selected Item" & Chr(13) & "Index, Key, Text:" & Chr(13)
With TreeView1.SelectedItem
strNodes = strNodes & .Index & "; " & .Key & "; " & .Text & "; " & .Image & Chr(13)
End With
MsgBox strNodes, , "TreeView1 Output"
Unload Me
End Sub
Private Sub UserForm_Initialize()
'Author: Paulo Mendonça 02/September/2014 ppmendonca#hotmail.com
Dim oNode, oParent As Node
Dim oCell As Range
Dim oShape As Shape
Dim iml As ImageList
Dim oImage, oSheet, oDataColumn As String
Dim oParentColumnOffset, oImageColumnOffset, oInitialDataRow As Integer
Dim oFound As Boolean
oSheet = "Sheet2"
oDataColumn = "A"
oInitialDataRow = 2
oImageColumnOffset = 2
oParentColumnOffset = 1
'create new ImagList and populate it
Set iml = New ImageList
'iml.ImageHeight = 256
'iml.ImageWidth = 256
iml.ListImages.Add 1, "red", RED.Picture 'defined in UserForm1 and set to invisible
iml.ListImages.Add 2, "green", GREEN.Picture 'defined in UserForm1 and set to invisible
For Each oShape In Sheets(oSheet).Shapes 'look up every shape in the sheet (including non-pictures and add a picture of it in iml
If oShape.Type = 13 Then 'if is picture
If Not PictureKeyExists(oShape.TopLeftCell.Address, iml) Then 'find if picture key exists, if not add it
oShape.CopyPicture xlScreen, xlBitmap 'copy shape to clipboard
iml.ListImages.Add 3, oShape.TopLeftCell.Address, PastePicture(xlBitmap) 'add a picture of the clipboard contents to iml with key = to shapes top left corner cell address
'NOTE: eventhough the index is set to 3 the actual index of the pictures gets incremented automatically
Else 'if yes report to user and don't add it
MsgBox "More than one image in cell " & oShape.TopLeftCell.Address & "." & Chr(13) & _
"Only one will be used."
End If
End If
Next
'set TreeView1 formats etc.
With TreeView1
Set .ImageList = iml
.Indentation = 14
.LabelEdit = tvwManual
.HideSelection = False
.CheckBoxes = True
.Style = tvwTreelinesPlusMinusPictureText
.BorderStyle = ccFixedSingle
End With
'populate TreeView1
With TreeView1.Nodes
.Clear
Set oNode = .Add(, , "Root", "Root Node") 'add root node; key = "Root"
oNode.Expanded = True
oNode.EnsureVisible
'look up all cells from A2 to last cell with content in it and add it to TreeView1
For Each oCell In Sheets(oSheet).Range(oDataColumn & oInitialDataRow, Sheets(oSheet).Range(oDataColumn & "65536").End(xlUp)).SpecialCells(xlCellTypeVisible)
'find if parent exists
Set oParent = Nothing
For Each oNode In TreeView1.Nodes
If oNode.Text = oCell.Offset(0, oParentColumnOffset).Value Then
Set oParent = oNode
Exit For
End If
Next
'find if picture exists, if yes use it, if not use "RED"
If PictureKeyExists(oCell.Offset(0, oImageColumnOffset).Address, iml) Then
oImage = oCell.Offset(0, oImageColumnOffset).Address
Else
oImage = "red"
End If
'add node
If oParent Is Nothing Then 'if parent not found add as child to root; key = name
Set oNode = .Add("Root", tvwChild, oCell.Value, oCell.Value, oImage)
oNode.Expanded = False
Else 'add as child to parent found previously; key = name concatenated to parent node key
Set oNode = .Add(oParent.Key, tvwChild, oParent.Key & "|" & oCell.Value, oCell.Value, oImage)
oNode.Expanded = False
End If
Next
End With
End Sub
Function PictureKeyExists(oKey As String, oImageList As ImageList) As Boolean
'Author: Paulo Mendonça 29/August/2014 ppmendonca#hotmail.com
Dim oPicture As ListImage
PictureKeyExists = False
For Each oPicture In oImageList.ListImages
If oPicture.Key = oKey Then
PictureKeyExists = True
Exit For
End If
Next
End Function
In microsoft excel vba, I am attempting to assign hyperlinks and/or actions to shapes I have drawn. Here is roughly what I have tried (uncomment only one line at a time)
Basically, what I want to do is allow users to get more information by clicking on a shape object. Hyperlinks are fine, but some kind of event handler which accepts parameters would be ideal. I will be creating hundreds of these shapes, and they need to link to unique places in the document.
Dim destinationHyperlinkCell as Range
set destinationHyperlinkCell = Range("10:10")
' (do some stuff here)...
With Sheet1.Shapes.AddTextbox(msoTextOrientationHorizontal, _
600, _
600, _
300, _
16)
.TextFrame.Characters.Text = "Test this thing"
.Name = destinationHyperlinkCell.Address & " group of shapes"
'.Hyperlink.Address = destinationHyperlinkCell.Address
'.Hyperlink.Range = destinationHyperlinkCell.Address
'.OnAction = "'showDebugMsg """ & .Name & """'"
End With
use "Assign Macro ..." to define a macro to each shape which fires on "Click"
You can use the same macro for each shape and use the Application.Caller property to get the name of the shape which fired the macro. Then you have all the ingredients to write an intelligent handler - like a (hidden) Excel table that resolves shape name into an URL, text or whatever
Sub Shape_Click()
MsgBox "Co-Cooo! from" & Application.Caller
End Sub
Hope that helps
Good luck - MikeD