I got this code off of YouTube to be able to fill out a user form and it transfer it over to a Microsoft word doc but I am having issues with the bookmark section of the code, I am unsure if I have to declare which bookmark is going to start off with or if the way it has it currently just looks at all of the bookmarks in the documents but for some reason is just not working
My bookmarks are
Part_Num
QTY
Return_add
RMA_Num
RTV
stock
Option Explicit
Dim doc As Document
Private Sub CommandButton1_Click()
'// data validations
'// RMA check
If Me.RMA_Number.Text = vbNullString Then
MsgBox "RMA Number is required.", vbInformation
Me.RMA_Number.SetFocus
Exit Sub
'// Stock Code Check
ElseIf Me.Stock_Code.Text = vbNullString Then
MsgBox "Stock Codeis required.", vbInformation
Me.Stock_Code.SetFocus
Exit Sub
'// Part Number Check
ElseIf Me.Part_Number.Text = vbNullString Then
MsgBox "Part Number required.", vbInformation
Me.Part_Number.SetFocus
Exit Sub
'// RTV Check
ElseIf Me.RTV.Text = vbNullString Then
MsgBox "RTV Number required.", vbInformation
Me.RTV.SetFocus
Exit Sub
'// QTY
ElseIf Not IsNumeric(Me.QTY.Text) Then
MsgBox "QTY is invalid.", vbInformation
Me.QTY.SetFocus
Exit Sub
'// Return Address Check
ElseIf Me.Return_Address.Text = vbNullString Then
MsgBox "Return_Address required.", vbInformation
Me.Return_Address.SetFocus
Exit Sub
End If
'// RMA
Call update_field("RMA_Num", Me.RMA_Number.Text)
'// Stock code
Call update_field("Stock", Me.Stock_Code.Text)
'// Part Num
Call update_field("Part_Num", Me.Part_Number.Text)
'// QTY
Call update_field("QTY", Me.QTY.Text)
'// Return Address
Call update_field("Return_add", Me.Return_Address.Text)
'// RTV
Call update_field("RTV_Num", Me.RTV.Text)
End Sub
Private Sub update_field(ByVal field_name As String, ByVal field_value As String)
Dim bk_mark As Bookmark
Dim start_location As Long, extended_distance As Long
'// bookmark name
Set bk_mark = doc.Bookmarks(field_name)
'// select bookmark
bk_mark.Select
start_location = bk_mark.Start
extended_distance = Selection.EndKey
If extended_distance > 0 Then
doc.Range(start_location, start_location + extended_distance).Delete
End If
'// update bookmark value
bk_mark.Range = field_value
Set bk_mark = Nothing
End Sub
Private Sub CommandButton2_Click()
Dim ctrl As Control
For Each ctrl In Me.Controls
If TypeName(ctrl) = "TextBox" Then
ctrl.Text = ""
End If
Next ctrl
End Sub
Private Sub UserForm_Terminate()
Set doc = Nothing
End Sub
I am having issues with this section of the code, i am not too sure why or if i need to declare a starting Bookmark but I am not too sure where, got the code from Youtube and modified it
Private Sub update_field(ByVal field_name As String, ByVal field_value As String)
Dim bk_mark As Bookmark
Dim start_location As Long, extended_distance As Long
'// bookmark name
Set bk_mark = doc.Bookmarks(field_name)
'// select bookmark
bk_mark.Select
start_location = bk_mark.Start
extended_distance = Selection.EndKey
If extended_distance > 0 Then
doc.Range(start_location, start_location + extended_distance).Delete
End If
'// update bookmark value
bk_mark.Range = field_value
Set bk_mark = Nothing
End Sub
Related
objJSO.GetField(strField).Value = (strFieldVal) - That is the line I'm recieving a 'type mismatch' error on.
I've found the code base from "My Engineering World". It is an old post.
I'm selecting a static PDF form and trying to write values from an excel doc to the PDF form which contains the same field names. The excel doc has the field names in column c20-149 with the values for those fields in d20-149. I'm trying to write the values for those fields into the selected PDF form.
Option Explicit
Sub btnToPDF_Click()
Dim objAcroApp As Object
Dim objAcroAVDoc As Object
Dim objAcroPDDoc As Object
Dim objJSO As Object
Dim fd As Office.FileDialog
Dim strFile As String
Dim strField As String
Dim strFieldVal As String 'Used to hold the field value
Dim r As Long 'Used to increase row number for strfield name
'Disable screen flickering.
Application.ScreenUpdating = False
'Choose the Onsite Survey form you want to fill
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the On-site survey PDF."
.Filters.Clear
.Filters.Add "PDF", "*.PDF"
'.Filters.Add "All Files", "*.*"
'If the .Show method returns False, the user clicked Cancel.
If .Show = True Then
strFile = .SelectedItems(1)
MsgBox (strFile)
End If
End With
'Initialize Acrobat by creating the App object.
Set objAcroApp = CreateObject("AcroExch.App")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Could not create the App object!", vbCritical, "Object error"
'Release the object and exit.
Set objAcroApp = Nothing
Exit Sub
End If
'Create the AVDoc object.
Set objAcroAVDoc = CreateObject("AcroExch.AVDoc")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Could not create the AVDoc object!", vbCritical, "Object error"
'Release the objects and exit.
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
Exit Sub
End If
On Error GoTo 0
'Open the PDF file.
If objAcroAVDoc.Open(strFile, "") = True Then
'Set the PDDoc object.
Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
'Set the JS Object - Java Script Object.
Set objJSO = objAcroPDDoc.GetJSObject
On Error GoTo 0
'Fill the form fields.
For r = 20 To 149
strField = Cells(r, 3)
strFieldVal = Cells(r, 4)
objJSO.GetField(strField).Value = CStr(strFieldVal)
If Err.Number <> 0 Then
'Close the form without saving the changes.
objAcroAVDoc.Close True
'Close the Acrobat application.
objAcroApp.Exit
'Inform the user about the error.
MsgBox "The field """ & strField & """ could not be found!", vbCritical, "Field error"
'Release the objects and exit.
Set objJSO = Nothing
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
Exit Sub
End If
Next r
'Save the form
objAcroPDDoc.Save 1, strFile
'Close the form without saving the changes.
'objAcroAVDoc.Close True
'Close the Acrobat application.
objAcroApp.Exit
'Release the objects.
Set objJSO = Nothing
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
'Enable the screen.
Application.ScreenUpdating = True
'Inform the user that forms were filled.
MsgBox "All forms were created successfully!", vbInformation, "Finished"
End If
MsgBox "Something bad happend :(...."
End Sub
OK... found my problem but I'm not sure how to trap the problem. I may not need to as I'm hoping I won't run into this problem. Hoping isn't the best strategy though... :)
My PDF form has fields of type numeric. All my test data in my value cells were alpha-numeric. Once I changed my quantity and cost cells to numeric values in my excel doc the form was written correctly.
Perhaps I can test for the PDF form field type. If it is numeric I'll log the field name and present a msgbox at the end of the operation that displays fields that could not be filled.
I did need to correct my objJSO line to '=strFieldVal'
I'm fairly certain you want...
strField = Cells(r, 3).Value
strFieldVal = Cells(r, 4).Value
objJSO.GetField(strField).Value = strFieldVal
...instead of the three corresponding lines you have.
Below is my final code. It includes basic error handling (more like logging). One problem I did have in this; If I was writing an alpha numeric string to the PDF field and the PDF field was numeric AND there wasn't a default value in the PDF field the PDF would throw and error that my code couldn't catch. As long as there was a default value in the PDF numeric field the error handler worked as planned. Feel free to make any comments. I'm guessing this looks like kindergarten work (maybe 1st grade??)
`Option Explicit
Sub btnToPDF_Click()
Dim objAcroApp As Object
Dim objAcroAVDoc As Object
Dim objAcroPDDoc As Object
Dim objJSO As Object
Dim fd As Office.FileDialog
Dim myWB As Workbook
Set myWB = ThisWorkbook
Dim ToPDFsh As Worksheet
Set ToPDFsh = myWB.Sheets("OSSDataDump")
Dim strFile As String
Dim strField As String
Dim strFieldVal As String 'Used to hold the field value
Dim msgFail As String
Dim colVal As Variant
Dim r As Integer 'Used to increase row number for strfield name
Dim e As Integer 'Used to track the number of errors
Dim colFail As Collection
Set colFail = New Collection
e = 0
'Disable screen flickering.
Application.ScreenUpdating = False
'Choose the Onsite Survey form you want to fill
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the On-site survey PDF."
.Filters.Clear
.Filters.Add "PDF", "*.PDF"
'If the .Show method returns False, the user clicked Cancel.
If .Show = True Then
strFile = .SelectedItems(1)
End If
End With
'Initialize Acrobat by creating the App object.
Set objAcroApp = CreateObject("AcroExch.App")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Could not create the App object!", vbCritical, "Object error"
'Release the object and exit.
Set objAcroApp = Nothing
Exit Sub
End If
'Create the AVDoc object.
Set objAcroAVDoc = CreateObject("AcroExch.AVDoc")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Could not create the AVDoc object!", vbCritical, "Object error"
'Release the objects and exit.
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
Exit Sub
End If
'Open the PDF file.
If objAcroAVDoc.Open(strFile, "") = True Then
'Set the PDDoc object.
Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
'Set the JS Object - Java Script Object.
Set objJSO = objAcroPDDoc.GetJSObject
'Fill the form fields.
For r = 20 To 149
strField = ToPDFsh.Cells(r, 3).Value
strFieldVal = ToPDFsh.Cells(r, 4).Value
If strFieldVal = "" Then GoTo BlankVal
objJSO.GetField(strField).Value = strFieldVal
On Error GoTo ErrHandler
BlankVal:
Next r
'Save the form
objAcroPDDoc.Save 1, strFile
'Close the form without saving the changes.
'objAcroAVDoc.Close True
'Close the Acrobat application.
objAcroApp.Exit
'Release the objects.
Set objJSO = Nothing
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
'Enable the screen.
Application.ScreenUpdating = True
'Inform the user that forms were filled.
If e <> 0 Then
For Each colVal In colFail
msgFail = msgFail & colVal & vbNewLine
Next colVal
MsgBox "Not all fields were filled" & vbNewLine & "The follwoing fields failed:" & vbNewLine & msgFail, vbExclamation, "Finished"
Exit Sub
End If
MsgBox "On site survey was filled successfully!", vbInformation, "Finished"
End If
Exit Sub
ErrHandler:
e = e + 1
If e > 7 Then
MsgBox "Something Bad happend... :(" & vbNewLine & "Form not filled", vbCritical, "Failed"
GoTo ErrHandlerExit
End If
colFail.Add strField
Resume Next
Exit Sub
ErrHandlerExit:
'Close the form without saving the changes.
objAcroAVDoc.Close True
'Close the Acrobat application.
objAcroApp.Exit
'Release the objects and exit.
Set objJSO = Nothing
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
'Enable the screen.
Application.ScreenUpdating = True
Exit Sub
End Sub`
I have a form with 3 buttons:
Save - which saves the form
NewReport - which becomes visible only after current form is saved and is supposed to clear the form and let the user input another form of data.
Close - which should close the application without saving the unfinished form.
I cannot seem to figure out how to control these functions using the Before Update event procedure.
One of the things that I do not understand is that the Save command doesn't actually wright the data to the table until I somehow change the focus of the form. So if my user is entering data and hits the Save button, at the completion of the save command, the table does not yet have the data saved. It only appears in the table after focus changes; like from a Requery.
Here is my code in its current version:
Option Compare Database
Option Explicit
Private Cause As Variant
Private Sub btnClose_Click()
Cause = "CloseButton"
DoCmd.Close acForm, "frmReports", acSaveNo
End Sub
Private Sub btnNewReport_Click()
Cause = "NewReport"
Me.Requery
Me.RepStatus = ""
End Sub
Private Sub cmdSave_Click()
Dim outl As Outlook.Application
Dim mi As Outlook.MailItem
'blnGood = True
Cause = "SaveButton"
'Save the Record
DoCmd.Save acForm, "frmReports"
' If Me.DateOfVisit <> "" Then
Me.RepStatus = "Report Saved!"
' Set outl = New Outlook.Application
' Set mi = outl.CreateItem(olMailItem)
' mi.Body = "A new report was just recorded."
' mi.Subject = Application.CurrentUser & " Just Logged a Report."
' mi.To = "rich.temen#cox.net"
' mi.Send
'
' Set mi = Nothing
' Set outl = Nothing
' End If
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
Dim strMsg As String
Select Case Cause
Case "SaveButton"
Me.btnNewReport.Visible = True
'do nothing
Case "NewReport"
'di this
Case "CloseButton"
Me.Undo
End Select
'If Not blnGood Then
' strMsg = "Please use the Save button to save your Report," & _
' vbNewLine & "or Escape to reset the form."
' Call MsgBox(Prompt:=strMsg, Title:="Before Update")
'End If
End Sub
Private Sub Form_Load()
Me.btnNewReport.Visible = False
Cause = ""
End Sub
Thanks for any help on this one, I have been going around in circles for hours.
Rich
Okay so when I press a specific button I want to loop through all forms, then find every control in each form with the tag 'TESTING'. If the tag = 'TESTING' then I want to change the caption of the object to 'abc123'.
The only objects with the tag 'TESTING' will be labels, so they will have the caption property.
So far I have this as the function:
Public Function changelabel()
On Error Resume Next
Dim obj As AccessObject, dbs As Object
Dim ctrl as Control
Set dbs = Application.CurrentProject
For Each obj In dbs.AllForms
DoCmd.OpenForm obj.Name, acDesign
For Each ctrl In Me.Controls
If ctrl.Tag = "TESTING" Then
ctrl.Caption = "abc123"
End If
Next ctrl
Next obj
End Function
Then this as the button code:
Public Sub TestButton_Click()
Call changelabel
End Sub
So it executes the first for loop and opens all the forms in design view correctly. The problem lies with the second for loop. None of the label captions that have the tag property as 'TESTING' are changed to 'abc123'.
So what do I need to change to get the second for loop to work?
Public Sub GetForms()
Dim oForm As Form
Dim nItem As Long
Dim bIsLoaded As Boolean
For nItem = 0 To CurrentProject.AllForms.Count - 1
bIsLoaded = CurrentProject.AllForms(nItem).IsLoaded
If Not bIsLoaded Then
On Error Resume Next
DoCmd.OpenForm CurrentProject.AllForms(nItem).NAME, acDesign
End If
Set oForm = Forms(CurrentProject.AllForms(nItem).NAME)
GetControls oForm
If Not bIsLoaded Then
On Error Resume Next
DoCmd.Close acForm, oForm.NAME
End If
Next
End Sub
Sub GetControls(ByVal oForm As Form)
Dim oCtrl As Control
Dim cCtrlType, cCtrlCaption As String
For Each oCtrl In oForm.Controls
If oCtrl.ControlType = acSubform Then Call GetControls(oCtrl.Form)
Select Case oCtrl.ControlType
Case acLabel: cCtrlType = "label": cCtrlCaption = oCtrl.Caption
Case acCommandButton: cCtrlType = "button": cCtrlCaption = oCtrl.Caption
Case acTextBox: cCtrlType = "textbox": cCtrlCaption = oCtrl.Properties("DataSheetCaption")
Case Else: cCtrlType = ""
End Select
If cCtrlType <> "" Then
Debug.Print oForm.NAME
Debug.Print oCtrl.NAME
Debug.Print cCtrlType
Debug.Print cCtrlCaption
End If
Next
End Sub
Something like this
Public Function changelabel()
Dim f As Form
Dim i As Integer
Dim c As Control
For i = 0 To CurrentProject.AllForms.Count - 1
If Not CurrentProject.AllForms(i).IsLoaded Then
DoCmd.OpenForm CurrentProject.AllForms(i).Name, acDesign
End If
Set f = Forms(i)
For Each c In f.Controls
If c.Tag = "TESTING" Then
c.Caption = "TESTING"
End If
Next c
Next i
End Function
You'll need to add a bit of house-keeping to set the objects used to nothing etc..
I am struggling with the above error when trying to write the Visual Basic code for a 2010 Access Form. I am trying to get ensure that the associate and the Team Lead get the same email. When I first wrote the code, it worked initially. I have since added an "issue date" to the form, but not to the email. I attempted to add the issue date to the Script, but that did not work. I have since removed both the issue date from the form and the script. Any help would appreciated:
Private Sub cmdEmail_Click()
Dim objOutlook As Object
Dim objMailItem As Object
Const olMailItem As Integer = 0
Dim objMailItem1 As Object
Const olMailItem1 As Integer = 0
Set objOutlook = CreateObject("Outlook.Application")
Set objMailItem = objOutlook.CreateItem(olMailItem)
Set objMailItem1 = objOutlook.CreateItem(olMailItem1)
Dim strPathAttach As String
On Error GoTo err_Error_handler
'set receipient, you can use a DLookup() to retrieve your associate Email address
objMailItem.To = DLookup("Email_ID", "dbo_Noble_Associates", "[Fullname]='" & Me.cboAssociate & "'")
objMailItem1.To = DLookup("Email_ID", "dbo_TeamLeads$", "[Fullname]='" & Me.txtTeamLead & "'")
'set subject with text and Form values
objMailItem.Subject = "Attendance Violation " & Me.cboAssociate
objMailItem1.Subject = "Attendance Violation " & Me.cboAssociate
'set body content with text and Form values etc.
objMailItem.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
objMailItem1.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
' display email
' objMailItem.Display
' sending mail automaticly
objMailItem.Send
objMailItem1.Send
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
exit_Error_handler:
On Error Resume Next
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
Exit Sub
err_Error_handler:
Select Case Err.Number
'trap error 287
Case 287
MsgBox "Canceled by user.", vbInformation
Case Else
MsgBox "Error " & Err.Number & " " & Err.Description
End Select
Resume exit_Error_handler
End Sub
Private Sub CheckEmail_Click()
End Sub
Private Sub cmdSaveandNew_Click()
If Me.txtOccurrence_Date & "" = "" Then
MsgBox "Please enter the date."
Me.txtOccurrence_Date.SetFocus
Exit Sub
ElseIf Me.cboAssociate & "" = "" Then
MsgBox "Please select the associate's name."
Me.cboAssociate.SetFocus
Exit Sub
ElseIf Me.txtPoints & "" = "" Then
MsgBox "Please enter the number of Points."
Me.txtPoints.SetFocus
Exit Sub
End If
If Me.CheckEmail = True Then
cmdEmail_Click
End If
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cmd_Cancel_Click()
Me.Undo
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cboassociate_AfterUpdate()
Me.txtTeamLead.Value = Me.cboAssociate.Column(1)
End Sub
Private Sub cboFullname_AfterUpdate()
Me.txtCurrentpoints.Value = Me.cbofullname.Column(1)
End Sub
Private Sub CboType_AfterUpdate()
Me.txtPoints.Value = Me.CboType.Column(1)
End Sub
I am open to any suggestions.
Here's what I want to do and I have a problem.
I want to restrict what an user types in certain textboxes. I want to leave him type only numbers but after 3 numbers to add a ";". (eg. 007;123;003;005;).
The problem is that my textbox Controls are generated through a bunch of code. So I can't or I don't know how to set an action to these controls.
The code I'm using to generate the controls is:
Set cControl = form.Controls("io" & masina).Add(
"Forms.Label.1", "lreper" & l & pagina, True)
With cControl
.Caption = "Reper"
.Width = 35
.Height = 9
.Top = 25 + k
.Left = 5
End With
Any ideas?
Thanks a lot!
You can use the key press event to restrict only numbers and the ";". Along with check conditions.
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
'// Numbers 0-9
Case 48 To 57
If Len(TextBox1.Text) = 3 And Right(TextBox1.Text, 3) Like "###" Then
KeyAscii = 0
GoTo DisplayFormatError
End If
'// Key ;
Case 59
If Len(TextBox1.Text) < 3 Or Not Right(TextBox1.Text, 3) Like "###" Then
KeyAscii = 0
GoTo DisplayFormatError
End If
Case Else
KeyAscii = 0
GoTo DisplayFormatError
End Select
Exit Sub
DisplayFormatError:
MsgBox "Please enter serial number in the format '000;000;000'", vbInformation, "Alert!"
End Sub
A better way would be to use a regular expression instead of the like method.
If you need help adding the events for your controls at runtime have a look at:
Add controls and events to form at runtime
EDIT (REQUEST BY TIAGO)
Dynamic creation of Userform and Textbox with keypress event. Uses modified example of above link. Credit to original author.
Add reference - Under Available References, click "Microsoft Visual Basic for Applications Extensibility" and click OK.
Option Explicit
Sub MakeForm()
Dim TempForm As Object ' VBComponent
Dim FormName As String
Dim NewTextBox As MSForms.TextBox
Dim TextLocation As Integer
Dim TextBoxName As String
'** Additional variable
Dim X As Integer
'Locks Excel spreadsheet and speeds up form processing
Application.VBE.MainWindow.Visible = False
Application.ScreenUpdating = False
'Create the UserForm
Set TempForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
'Set Properties for TempForm
With TempForm
.Properties("Caption") = "Temporary Form"
.Properties("Width") = 200
.Properties("Height") = 100
End With
FormName = TempForm.Name
TextBoxName = "MyTextBox"
'Add a CommandButton
Set NewTextBox = TempForm.Designer.Controls _
.Add("Forms.TextBox.1")
With NewTextBox
.Name = TextBoxName
.Left = 60
.Top = 40
End With
'Add an event-hander sub for the CommandButton
With TempForm.CodeModule
'** Add/change next 5 lines
'This code adds the commands/event handlers to the form
X = .CountOfLines
.InsertLines X + 1, "Private Sub " & TextBoxName & "_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)"
.InsertLines X + 2, "KeyAscii = KeyPress(" & TextBoxName & ".Text, KeyAscii)"
.InsertLines X + 3, "End Sub"
End With
'Show the form
VBA.UserForms.Add(FormName).Show
'Delete the form
ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=TempForm
End Sub
Public Function KeyPress(ByVal strText As String, ByVal KeyAscii As Integer) As Integer
Select Case KeyAscii
'// Numbers 0-9
Case 48 To 57
If Len(strText) = 3 And Right(strText, 3) Like "###" Then
GoTo DisplayFormatError
End If
'// Key ;
Case 59
If Len(strText) < 3 Or Not Right(strText, 3) Like "###" Then
GoTo DisplayFormatError
End If
Case Else
GoTo DisplayFormatError
End Select
KeyPress = KeyAscii
Exit Function
DisplayFormatError:
KeyPress = 0
MsgBox "Please enter serial number in the format '000;000;000'", vbInformation, "Alert!"
End Function
ANOTHER METHOD (Using an event handler class)
Code in Userform:
Private colEventHandlers As Collection
Private Sub UserForm_Initialize()
'// New collection of events
Set colEventHandlers = New Collection
'// Add dynamic textbox
Set tbxNewTextbox = Me.Controls.Add("Forms.TextBox.1", "MyNewTextbox", True)
With tbxNewTextbox
.Top = 25
.Left = 5
End With
'// Add the event handler
Dim objEventHandler As TextboxEventHandler
Set objEventHandler = New TextboxEventHandler
Set objEventHandler.TextBox = tbxNewTextbox
colEventHandlers.Add objEventHandler
End Sub
And add a class module and rename it too "TextBoxEventHandler", then add the following code:
Private WithEvents tbxWithEvent As MSForms.TextBox
Public Property Set TextBox(ByVal oTextBox As MSForms.TextBox)
Set tbxWithEvent = oTextBox
End Property
Private Sub tbxWithEvent_Change()
End Sub
Private Sub tbxWithEvent_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
'// Numbers 0-9
Case 48 To 57
If Len(tbxWithEvent.Text) = 3 And Right(tbxWithEvent.Text, 3) Like "###" Then
GoTo DisplayFormatError
End If
'// Key ;
Case 59
If Len(tbxWithEvent.Text) < 3 Or Not Right(tbxWithEvent.Text, 3) Like "###" Then
GoTo DisplayFormatError
End If
Case Else
GoTo DisplayFormatError
End Select
Exit Sub
DisplayFormatError:
KeyAscii = 0
MsgBox "Please enter serial number in the format '000;000;000'", vbInformation, "Alert!"
End Sub
Try Dataannotations / metadata
More here: http://msdn.microsoft.com/en-us/library/ee256141.aspx
AFAIK and if i understood well, there is no way to handle this before user input.
Yet, you can use the TextBox_Exit event to format it afterwards. You can adapt this sample of code.
Although I'd never use dynamic controls unless strictly required, I got puzzled by this question... so I'm thinking of it as a challenge. :-)
Googled around and most answers falls into the same solution, however most of them comes with a 'I couldn't make it work' comment as well, including this one here in SO Assign on-click VBA function to a dynamically created button on Excel Userform.
Here's the code I built... which obviously does not work, otherwise I'd say it could be a solution. The problem on it is that the keypress method it creates dynamically is not called when should be. To test it, just paste the code into a VBA form named 'myForm'.
I kept the TextBox1_KeyPress only for testing purposes, to prove the usability of the text field validator (I'm sorry #Readfidy, your code didn't work for me as expected. I was able to add more than 3 numbers in a row).
In case anyone else is interested in making this code works... I'd be happy to thank ;-)
Option Explicit
Private Sub UserForm_Activate()
Dim sTextBoxName As String
Dim cControl As MSForms.TextBox
Dim sMetaFunction As String
Dim CodeModule
sTextBoxName = "lreper"
Set cControl = myForm.Controls.Add("Forms.TextBox.1", sTextBoxName, True)
With cControl
.Top = 25
.Left = 5
End With
sMetaFunction = "Private Sub " & sTextBoxName & "_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)" & vbCrLf & _
vbCrLf & _
vbTab & "Set KeyAscii = EvaluateText(myForm.Controls(" & sTextBoxName & "), KeyAscii)" & vbCrLf & _
vbCrLf & _
"End Sub"
Set CodeModule = ActiveWorkbook.VBProject.VBComponents.VBE.ActiveCodePane.CodeModule
CodeModule.InsertLines 60, sMetaFunction
End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Set KeyAscii = EvaluateText(myForm.Controls("TextBox1"), KeyAscii)
End Sub
Private Function EvaluateText(ByRef oTextBox As MSForms.TextBox, ByVal KeyAscii As MSForms.ReturnInteger) As MSForms.ReturnInteger
If ((Len(oTextBox.Text) + 1) / 4 = CInt((Len(oTextBox.Text) + 1) / 4)) Then
If KeyAscii <> 59 Then KeyAscii = 0
Else
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End If
If KeyAscii = 0 Then
MsgBox "Please enter serial number in the format '000;000;000'", vbInformation, "Alert!"
End If
End Function
USE THIS CODE : NO CLASS NEEDED !
USERFORM CODE
Private Function QNumber(ByRef oTextBox As MSForms.TextBox, ByVal KeyAscii As MSForms.ReturnInteger) As MSForms.ReturnInteger
On Error Resume Next
Select Case KeyAscii
Case 45 '"-"
If InStr(1, oTextBox.Text, "-") > 0 Or oTextBox.SelStart > 0 Then
KeyAscii = 0
End If
Case 46 '"."
If InStr(1, oTextBox.Text, ".") > 0 Then
KeyAscii = 0
End If
Case 48 To 57 '0-9"
Case Else
KeyAscii = 0
End Select
End Function
TEXTBOX CODE
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Set KeyAscii = QNumber(Me.Controls("TextBox1"), KeyAscii)
End Sub