Read specific line from text file, according to Checked Listbox selection number - select

i want to create an application which will read a specific line from a text file and show it in a textbox. The line will be chosen according to the number of the listbox selection i will make.
Here's the code:
Public Class Form1
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim i As Integer
For i = 0 To Me.CheckedListBox1.CheckedIndices.Count - 1
Me.CheckedListBox1.SetItemChecked(Me.CheckedListBox1.CheckedIndices(0),False)
Next i
End Sub
Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
If CheckedListBox1.CheckedItems.Count <> 0 Then
Dim reader As New System.IO.StreamReader(CurDir() & "\" & "READ.txt")
Dim x As Integer
Dim s As String = ""
For x = 0 To CheckedListBox1.CheckedItems.Count - 1
s = s & "Answer " & (x + 1).ToString & ") " & CheckedListBox1.CheckedItems(x).ToString & ControlChars.CrLf & reader.ReadLine() & ControlChars.CrLf & ControlChars.CrLf
Next x
Answer.Text = (s)
Else
MessageBox.Show("Please select questions.", "Error", _
MessageBoxButtons.OK, _
MessageBoxIcon.Information)
Return
End If
End Sub
End Class
So lets say i 'check' the first, second, and fifth items from the checked listbox, i want it to read from the text file the first, second, and fifth lines of text and show them in the textbox.
The current code just reads line 1, 2, 3 (...) in order, no matter what item i have 'checked'.

Increment a counter each time your read a line from the file to track which line you are reading and only add a line to the text box when your line number matches a selected line number.

Related

How to display Parameter Window data to a Label in VISIO

I am trying to assign value to a LABEL in VISIO. But it is not working. Can you help me.
After I drag and drop my component on the right click I am giving an option "ADD STATION" this will add a LABEL to the component and after that I want to get value from the Parameter window and display it into the LABEL.
I am able to generate the LABEL on a button click I want some help to display the Value.
Public Sub AddParameterToLabel(ByRef oLabel As Visio.Shape, ByRef sObjID As String, ByRef sParameterName As String, ByVal sPreText As String, ByVal bShow As Boolean)
Dim sRowName As String = "Parameter"
Dim iCurrentRow As Integer = oLabel.AddNamedRow(visSectionUser, sRowName, 0)
If (Err.Number <> 0) Then
Err.Clear()
Dim iAddRow As Integer = oLabel.AddNamedRow(visSectionUser, "VisioSucks3", 0)
oLabel.CellsSRC(visSectionUser, iAddRow, 1).RowName = sRowName
iCurrentRow = iAddRow
End If
Dim ovCell As Visio.Cell = oLabel.CellsSRC(visSectionUser, iCurrentRow, visUserValue)
Dim sParent As String = sObjID
If (Len(sObjID) > 0) Then
sParent = sObjID & DOT
End If
Dim oParam As Object.Interop.Param
oParam = g_oObject.Param(sParent & sParameterName)
Dim sPacked As String
If (Err.Number <> 0) Then
sPacked = "|-1|1|0|||||"
Else
'Add parameters with the unit conversions, as specified by the current choice
sPacked = sParameterName & "|" &
oParam.SigFigs & "|" &
oParam.MultiplierToUserUnit & "|" &
oParam.AdderToUserUnit & "|" &
"|" &
sPreText & "|" &
"|" &
"g" & oParam.SigFigs & "|" &
"User" & "|" &
oParam.UserUnitsString
End If
If Not oParam Is Nothing Then
System.Runtime.InteropServices.Marshal.FinalReleaseComObject(oParam)
oParam = Nothing
End If
ovCell.FormulaU = FormatStringForVisioOrSQL(sPacked)
oLabel.CellsSRC(visSectionUser, iCurrentRow, visUserPrompt).Result(visNoCast) = Math.Abs(CInt(bShow))
oLabel.Cells("Actions.Action[1]").Trigger()
End Sub
The "ParameterName = Compressor.StationFrom" which I am getting here.
and the value StationFrom will be having is DOUBLE i.e 1.2,1.3 etc..

simplest Unostructure that supports he getByName

In LibreOffice Basic sub I use a bunch of uno properties in an array. Which is the simplest Unostructure or UnoService that I must "embed" them, in order to use the getByName "function"?
Example:
dim props(1) as new com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
I want to be able to use something like:
b = props.getByName("blahblah2").Value
or something like (assuming I "assigned" them in a structure-like-object called "somestruct") :
b = somestruct.getprops.getByName("blahblah2").Value
As I understand that this can be done by creating a "UnoService" which supports the getByName and then, somehow, assigning these props to this service
Which is the "lightest" such service?
(I mean the service that uses less resources)
Thanks in advance.
Really supporting the interface XNameAccess is not as easy. The services which implement this interface are supposed using this interface for existing named properties, not for own created ones.
But you can use the service EnumerableMap to achieve what you probably want.
Example:
sub testEnumerableMap
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
oEnumerableMap.put("blahblah1", "blahblah1Value")
oEnumerableMap.put("blahblah2", 3000)
oEnumerableMap.put("blahblah3", 1234.67)
msgbox oEnumerableMap.get("blahblah1")
msgbox oEnumerableMap.get("blahblah2")
msgbox oEnumerableMap.get("blahblah3")
'msgbox oEnumerableMap.get("blahblah4") 'will throw error
msgbox oEnumerableMap.containsKey("blahblah2")
msgbox oEnumerableMap.containsValue(3000)
if oEnumerableMap.containsKey("blahblah4") then
msgbox oEnumerableMap.get("blahblah4")
end if
end sub
But starbasic with option Compatible is also able supporting Class programming like VBA does.
Example:
Create a module named myPropertySet. Therein put the following code:
option Compatible
option ClassModule
private aPropertyValues() as com.sun.star.beans.PropertyValue
public sub setProperty(oProp as com.sun.star.beans.PropertyValue)
bUpdated = false
for each oPropPresent in aPropertyValues
if oPropPresent.Name = oProp.Name then
oPropPresent.Value = oProp.Value
bUpdated = true
exit for
end if
next
if not bUpdated then
iIndex = ubound(aPropertyValues) + 1
redim preserve aPropertyValues(iIndex)
aPropertyValues(iIndex) = oProp
end if
end sub
public function getPropertyValue(sName as string) as variant
getPropertyValue = "N/A"
for each oProp in aPropertyValues
if oProp.Name = sName then
getPropertyValue = oProp.Value
exit for
end if
next
end function
Then within a standard module:
sub testClass
oPropertySet = new myPropertySet
dim prop as new com.sun.star.beans.PropertyValue
prop.Name = "blahblah1"
prop.Value = "blahblah1Value"
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 3000
oPropertySet.setProperty(prop)
prop.Name = "blahblah3"
prop.Value = 1234.56
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 8888
oPropertySet.setProperty(prop)
msgbox oPropertySet.getPropertyValue("blahblah1")
msgbox oPropertySet.getPropertyValue("blahblah2")
msgbox oPropertySet.getPropertyValue("blahblah3")
msgbox oPropertySet.getPropertyValue("blahblah4")
end sub
LibreOffice Basic supports the vb6 Collection type.
Dim coll As New Collection
coll.Add("blahblah1Value", "blahblah1")
coll.Add(3000, "blahblah2")
MsgBox(coll("blahblah1"))
Arrays of property values are the only thing that will work for certain UNO interfaces such as dispatcher calls. If you simply need a better way to deal with arrays of property values, then use a helper function.
Sub DisplayMyPropertyValue
Dim props(0 To 1) As New com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
MsgBox(GetPropertyByName(props, "blahblah1"))
End Sub
Function GetPropertyByName(props As Array, propname As String)
For Each prop In props
If prop.Name = propname Then
GetPropertyByName = prop.Value
Exit Function
End If
Next
GetPropertyByName = ""
End Function
XNameAccess is used for UNO containers such as Calc sheets. Normally these containers are obtained from the UNO interface, not created.
oSheet = ThisComponent.Sheets.getByName("Sheet1")
May UNO objects support the XPropertySet interface. Normally these are also obtained from the UNO interface, not created.
paraStyleName = cellcursor.getPropertyValue("ParaStyleName")
It may be possible to create a new class in Java that implements XPropertySet. However, Basic uses helper functions instead of class methods.
I think the serviceEnumerableMap is the answer (so far). Creating the values and searching them was much faster then creating props in a dynamic array and searching them with a for loop in basic.
(I do not "dare" to use "option Compatible", although I was a big fun of VB6 and VBA, because of the problems in code that maybe arise).
I used this code to test time in a form:
SUB testlala(Event)
TESTPROPS(Event)
' TESTENUM(Event)
MSGBOX "END OF TEST"
END SUB
SUB TESTENUM(Event)
DIM xcounter AS LONG
'b = now()
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
FOR xcounter= 0 TO 10000
oEnumerableMap.put("pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g =oEnumerableMap.get("pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
SUB TESTPROPS(Event)
DIM props()
DIM xcounter AS LONG
'b = now()
FOR xcounter= 0 TO 10000
AppendProperty(props,"pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g = GetValueFromName(props,"pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
REM FROM Andrew Pitonyak's OpenOffice Macro Information ------------------
Sub AppendToArray(oData(), ByVal x)
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Sub
Function CreateProperty(sName$, oValue) As com.sun.star.beans.PropertyValue
Dim oProperty As New com.sun.star.beans.PropertyValue
oProperty.Name = sName
oProperty.Value = oValue
CreateProperty() = oProperty
End Function
Sub AppendProperty(oProperties(), sName As String, ByVal oValue)
AppendToArray(oProperties(), CreateProperty(sName, oValue))
End Sub

Microsoft Access - Loop through all forms and controls on each form

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..

Loop subroutine for every used row using multiple dynamic cell references

Basically what I am trying to do is, sending an email for every used row on the target worksheet, each row has the details of the addresses, subject line, table with values etc.
So I can't seem to get it working, as it only dispatches one email from the first target row (2nd row).
I have tried using a combination of For Each and For i = 1 to LR which aren't working. I suspect it is to do with the cell references.
Here is the code:
Sub TestEmail1()
Application.ScreenUpdating = False
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim ccAddresses As Range, ccCell As Range, ccRecipients As String
Dim rngeSubject As Range, SubjectCell As Range, SubjectContent As Variant
Dim rngeBody As Range, bodyCell As Range, bodyContent As Variant
Dim Table1 As Range
Dim i As Integer
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
Set rng = ActiveSheet.UsedRange
LRow = rng.Rows.Count
For i = 2 To LRow
Set Table1 = Worksheets(1).Range("K1:R1")
Set Table2 = Worksheets(2).Range("K" & i & ":" & "R" & i)
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'set sheet to find address for e-mails as I have several people to
'mail to
Set rngeAddresses = ActiveSheet.Range("B" & i)
For Each rngeCell In rngeAddresses.Cells
strRecipients = strRecipients & ";" & rngeCell.Value
Next
Set ccAddresses = ActiveSheet.Range("C" & i)
For Each ccCell In ccAddresses.Cells
ccRecipients = ccRecipients & ";" & ccCell.Value
Next
Set rngeSubject = ActiveSheet.Range("D" & i)
For Each SubjectCell In rngeSubject.Cells
SubjectContent = SubjectContent & SubjectCell.Value
Next
Set rngeBody = ActiveSheet.Range("E" & i)
For Each bodyCell In rngeBody.Cells
bodyContent = bodyContent & bodyCell.Value
Next
'set Importance
'aEmail.Importance = 2
'Set Subject
aEmail.Subject = rngeSubject
'Set Body for mail
'aEmail.Body = bodyContent
aEmail.HTMLBody = bodyContent & "<br><br><br>" & RangetoHTML_ (Table1)
aEmail.To = strRecipients
aEmail.CC = ccRecipients
aEmail.Send
Exit Sub
Next i
Next c
End Sub
There is an Exit Sub at the end of your inner loop that makes the code exit from the procedure after the first iteration:
Sub TestEmail1()
...
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
...
For i = 2 To LRow
...
Exit Sub
Next i
Next c
End Sub
Remove it and processing should continue as desired.

Restrict what someone types in a textbox

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