I need to create a web form that -- 1. checks if a serial number is correct. I have the script that does this in VBScript and I am trying to incorporate that into a form. It is a simple algorithm as shown below (the licence format is 9999-999999):
Dim strID
Dim ColCSum3
Dim ChkVal
Dim InitVal
strID = InputBox("Please enter the the serial number to verify", "Verify serial")
If strID = "" Then wscript.Quit
If mid(strID, 5, 1) <> "-" Or Len(strID) <> 11 Then MsgBox "Invalid number format...", 16, "Input error": wscript.Quit
InitVal = CLng(Left(strID, 1))
ChkVal = CLng(Mid(strID, 2, 3))
ColCSum3 = (2 * CLng(Mid(strID, 6, 1)) + _
7 * CLng(Mid(strID, 7, 1)) + _
6 * CLng(Mid(strID, 8, 1)) + _
3 * CLng(Mid(strID, 9, 1)) + _
5 * CLng(Mid(strID, 10, 1)) + _
4 * CLng(Mid(strID, 11, 1))) * 3
If 11 * InitVal + ColCSum3 + 3 = ChkVal Then
MsgBox strID & " is a valid serial number..", 64, "Validated"
Else
MsgBox strID & " is not a valid serial number", 48, "Invalid"
End If
and 2. Once this works, would the key inputed by the user be able to get stored into a database somewhere so that it does not get used again? So I guess the form would also have to check against this field of the database.
The main site is in WordPress but I could set this up as a standalone page if need be. Maybe there is a good WP form plugin that is capable of doing this?
Many thanks.
Related
I was working on a Tableau Project. We want to have a separator for five or more digits numbers.
For ex:-
1 as 1
12 as 12
123 as 123
1234 as 1234
12345 as 12,345
123456 as 1,23,456
Can you please assist me, how to achieve this?
I am nearly sure that this cannot be done as long as numbers are formatted as numbers. However, as a workaround, I have developed a method which however will convert numbers to string. Let's say you have a column col of desired numbers
copy your column say col2 (save original for future use) and convery type to string
Create a new calculated field say desired by using this calculation
If LEN([Col2]) <= 4 THEN
[Col2]
ELSEIF LEN([Col2]) < 6 THEN
REPLACE([Col2], RIGHT([Col2], 3), "") + "," +RIGHT([Col2], 3)
ELSEIF LEN([Col2]) <8 THEN
REPLACE([Col2], RIGHT([Col2], 5), "") + "," +
REPLACE(RIGHT([Col2],5), RIGHT([Col2], 3), "") + "," +RIGHT([Col2], 3)
ELSE
REPLACE([Col2], RIGHT([Col2], 7), "") + "," +
REPLACE(RIGHT([Col2],7), RIGHT([Col2], 5), "") + "," +
REPLACE(RIGHT([Col2],5), RIGHT([Col2], 3), "") + "," +RIGHT([Col2], 3)
END
this CF will work exactly as desired for upto 9 digits.
Alignment is not a big problem, if considered
I have a requirement where I take a SUBSTR (e.g st_detail = "%BOM0007992739871P", st_digit = SUBSTR(st_detail, 8, 10) ). I have to do some validations on the st_digit and if it is valid change "%BOM0002562186P" to "%BOM0002562186C". My code works fine upto this. But I was asked to increment st_digit (I used st_digit = st_digit + 1 ) and print 100 valid st_digits and append it with C. so I put the code in a loop and display st_detail. But when i ran it i got "%BOM0007.99273987E+9C" after first increment. Please help on how to display "%BOM0007992739872C"? (NOTE: this is a reference only and I can't display the validation logic here and my code works fine. The extra code i added was the code I used here)
out_ctr = 1
DO while out_ctr < 101
/* validations */
IF valid THEN
say st_digit " is valid"
ELSE
say st_digit " is invalid"
st_digit = st_digit + 1
out_ctr = out_ctr + 1
END
It seems the NUMERIC setting was " 9 0 SCIENTIFIC ". I changed it to NUMERIC DIGITS 12, So, now it works.
parse numeric my_numeric_settings
say my_numeric_settings /* 9 0 SCIENTIFIC */
NUMERIC DIGITS 16
parse numeric my_numeric_settings
say my_numeric_settings /* 16 0 SCIENTIFIC */
It's because I used SUBSTR(st_detail, 8, 10),So, st_digit is of length 10, which is greater than the DEFAULT setting of "9 0 SCIENTIFIC", So by changing it to either "NUMERIC DIGITS 10" or "NUMERIC DIGITS 12" the code worked.
I have hexadecimal string which consists of different languages letters.
Please help me with a vb-script function which converts this hexadecimal string to Unicode text.
For hex string "506F7274756775C3AA73" , I need to get "Português" as output.
I tried following function, it gives "Português" as output.
MsgBox ConvertHexToUnicode("506F7274756775C3AA73")
Function ConvertHexToUnicode(hexString)
Dim Strlen
Dim Charaset_array(20)
Dim i
Dim j
Strlen = Len(hexString)
i = 0
j = 1
Do
Charaset_array(i) = Mid(hexString,j, 2)
i = i + 1
j = j + 2
Loop While j < Strlen
ConvertHexToUnicode = ""
For Each chara In Charaset_array
If Not(IsEmpty(chara)) Then
ConvertHexToUnicode = ConvertHexToUnicode + ChrW("&H" & chara )
End If
Next
End Function
Use Mid() to cut your input string into hex numbers (strings), prepend &H to get hex literals, and ChrW() to build characters:
>> s = "00001F00"
>> WScript.Echo Mid(s, 5, 4)
>> WScript.Echo "&H" & Mid(s, 5, 4), CLng("&H" & Mid(s, 5, 4))
>> WScript.Echo ChrW("&H" & Mid(s, 5, 4)), AscW(ChrW("&H" & Mid(s, 5, 4)))
>>
1F00
&H1F00 7936
ἀ 7936
I am trying to create a form with vba and for that I am using the following code:
Private Sub createButton_Click()
Dim cSlide As Slide
Dim survey As Shape
Dim text As String
Dim top As Integer
'Dim TempForm As Object ' VBComponent
Dim FormName As String
Dim NewButton As MSForms.CommandButton
Dim TextLocation As Integer
' ** Additional variable
Dim X As Integer
If singleOption.value Then
typ = "radio"
Else
If multipleOption.value Then
typ = "checkBox"
Else
If dropdown.value Then
typ = "dropdown"
Else
MsgBox "Please, select survey type before continue"
Exit Sub
End If
End If
End If
If tagBox = "" Then
MsgBox "Please, write a title before continue"
Exit Sub
End If
If choiceNum = "" Then
MsgBox "Please, set the options number"
Exit Sub
End If
'Locks Excel spreadsheet and speeds up form processing
Application.VBE.MainWindow.Visible = False
'Application.ScreenUpdating = False
choNum = choiceNum
' Create the UserForm
Set TempForm = ActivePresentation.VBProject.VBComponents.Add(vbext_ct_MSForm)
'TempForm.Activate
'Set Properties for TempForm
With TempForm
.Properties("Caption") = "Possible answers"
.Properties("Width") = 300
.Properties("Height") = 10 + 34 * choiceNum + 50
End With
FormName = TempForm.Name
For i = 1 To choiceNum
Set newTab = TempForm.Designer.Controls.Add("Forms.Label.1", "label" & i, True)
With newTab
.Caption = "Answer" & i
.width = 40
.height = 15
.top = 10 + 30 * (i - 1)
.left = 10
End With
Set cCntrl = TempForm.Designer.Controls.Add("Forms.TextBox.1", "textBox" & i, True)
With cCntrl
.width = 150
.height = 15
.top = 10 + 30 * (i - 1)
.left = 60
.ZOrder (0)
End With
Next i
Set NewButton = TempForm.Designer.Controls.Add("forms.CommandButton.1", "answerButton", True)
With NewButton
.Caption = "Create survey"
.left = 60
.top = 30 * choiceNum + 10
End With
ActiveWindow.Selection.Unselect
Set cSlide = Application.ActiveWindow.View.Slide
Set survey = cSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 20, 400, 20)
survey.TextFrame.TextRange.Font.Size = 25
survey.TextFrame.TextRange.text = tagBox
height = survey.height
survey.Select
'X = ActivePresentation.VBProject.VBComponents(FormName).CodeModule.CountOfLines
With TempForm.CodeModule
X = .CountOfLines + 1
.InsertLines X + 1, "Sub answerButton_Click()"
.InsertLines X + 2, " Dim cSlide As Slide"
.InsertLines X + 3, " Dim survey As Shape"
.InsertLines X + 4, " Dim top As Integer"
.InsertLines X + 5, " Set cSlide = Application.ActiveWindow.View.Slide"
.InsertLines X + 6, " top = 30 + surveyCreation.height - 20"
.InsertLines X + 7, " "
.InsertLines X + 8, " For i = 1 To surveyCreation.choNum"
.InsertLines X + 9, " "
.InsertLines X + 10, " top = top + 15"
.InsertLines X + 11, " Set survey = cSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 30, top, 400, 10)"
.InsertLines X + 12, " survey.TextFrame.TextRange.text = Me.Controls(i * 2 - 1).Text"
.InsertLines X + 13, " "
.InsertLines X + 14, " survey.TextFrame.TextRange.ParagraphFormat.Bullet = True"
.InsertLines X + 15, " survey.TextFrame.TextRange.ParagraphFormat.Bullet.Type = ppBulletUnnumbered"
.InsertLines X + 16, " survey.Select Replace:=False"
.InsertLines X + 17, " Next i"
.InsertLines X + 18, " With ActiveWindow.Selection.ShapeRange"
.InsertLines X + 19, " .Group.title = ""Dink survey creation"" & surveyCreation.typ"
.InsertLines X + 20, "End With"
.InsertLines X + 21, "Application.VBE.ActiveVBProject.VBComponents.Remove Application.VBE.ActiveVBProject.VBComponents(Application.VBE.ActiveVBProject.VBComponents.Count)"
.InsertLines X + 22, "End Sub"
End With
'TempForm.Activate
tagBox.text = ""
choiceNum = ""
'ActivePresentation.VBProject.VBComponents.Add vbext_ct_MSForm
surveyCreation.Hide
'TempForm.Show
VBA.UserForms.Add(FormName).Show
ActivePresentation.VBProject.UserForms
End Sub
It is working well if I run the code in the presentation were I create the macro but if I want to exec it in another other it gives me the "object required" error. I try with ActivePresentation.VBA witch is not even compiling.
EDIT:
I create a ppam file and add it to powerpoint but it is giving me the same problem even in the presentation were I create it. So if I exec the code in the presentation were I create it, it works. But if I exec the ppam code (I add a button to exec it) it is giving me object required error.
OK, I have had some time to test this out.
I add some code which will create a standard code module at runtime in the ActivePresentation, with one subroutine called ShowMe. This subroutine can then be called from:
Application.Run ActivePresentation.Name & "!ShowMe"
Here is the sample code. I have tested it in a PPAM file and it successfully creates & shows the UserForm in the ActivePresentation.
Option Explicit
Sub Test()
Dim TempForm As Object 'VBComponent / Late Binding
Dim showModule As Object 'VBComponent
Dim FormName As String
Dim choiceNum As Long: choiceNum = 3
Dim vbComps As Long
Dim X As Long
Set TempForm = ActivePresentation.VBProject.VBComponents.Add(3) 'vbext_ct_MSForm
With TempForm
.Properties("Caption") = "Possible answers"
.Properties("Width") = 300
.Properties("Height") = 10 + 34 * choiceNum + 50
FormName = .Properties("Name")
End With
'## Insert a standard code module which will contain a subroutine to show the TempForm
Set showModule = ActivePresentation.VBProject.VBComponents.Add(1) 'vbext_ct_StdModule
With showModule.CodeModule
X = .CountOfLines + 1
.InsertLines X + 1, "Sub ShowMe()"
.InsertLines X + 2, " " & FormName & ".Show"
.InsertLines X + 3, "End Sub"
End With
Application.Run ActivePresentation.Name & "!ShowMe"
'## Remove the module & user form created, above
ActivePresentation.VBProject.VBComponents.Remove TempForm
ActivePresentation.VBProject.VBComponents.Remove showModule
'## Clean up
Set TempForm = Nothing
Set showModule = Nothing
End Sub
While I think there is maybe another way of achieving this (similar to what you were trying with a .Show method), I was not able to make that work. The above method seems to be reliable.
NOTE I am using Option Explicit. Your code has undeclared variables so this will raise some warnings and your code will not execute until you clean it up.
I haven't studied the code in detail, but choose the File menu (Backstage View in 2010) PowerPoint Options, Trust Center, click Trust Center Settings and check "Trust access to the vba project object model".
ISSUE
I am trying to convert a 8 digit number into a date while in an array. Examples of the entries are 12282009 or 12202007. There are other malformed entries in the field including dates entered as strings. I want the 8 digit number to be formatted as 12/28/09 or 12/20/07 respectively. I keep getting a type mismatch error on the third to last line below. How do I do this??
CODE
Dim del()
ReDim del(1 To importwsRowCount, 1 To 1)
del = Range("AH1:AH" & importwsRowCount).Value
Dim delChars As Long
Dim delType As String
For i = LBound(del, 1) To UBound(del, 1)
delChars = Len(del(i, 1)) 'Determine length of entry
If IsNumeric(del(i, 1)) = True Then 'Determine datatype of entry
delType = "Numeric"
del(i, 1) = Abs(del(i, 1))
Else
delType = "String"
del(i, 1) = UCase(del(i, 1))
End If
If delType = "Numeric" Then
If delChars = 8 Then
del(i, 1) = DateSerial((Right(del(i, 1), 4)), (Left(del(i, 1), 2)), (Mid(del(i, 1), 3, 2))) '<-- TYPE MISMATCH ERROR
End If
End If
ENTRY TEMPLATES
SEPT. 25, 20 (No year, no year! Delete.)
SEPT (No year, useless, delete.)
N/A (Rubbish! Deleted.)
LONG TIME AG (What moron thought this was a good idea, delete.)
JUNE 30, 200 (Apparently the field will only hold 12 characters, delete.)
CHARGED OFF (Useless, delete.)
94 DAYS (Take all characters preceding space and subtract from other field containing order date to obtain delinquent date.)
94 DPD (DPD in someones bright mind stands for Days Past Due I believe. Same as above.)
2008-7-15 12 (Not sure what additional number is, take all characters before space and transform.)
INVALID (Delete.)
BLANK (Do nothing.)
4/2/4/09 (Malformed date, delete.)
1/1/009 (Same as above.)
12282009 (Use nested LEFT and RIGHT and CONCATENATE with / in between.)
9202011 (Add leading zero, then same as above.)
92410 (Add leading zero, this will transform to 09/24/10)
41261 (Days since 31/12/1899, this will transform to 12/08/12)
1023 (Days since delinquent, subtract from ORDER DATE to get delinquent date.)
452 (Same as above.)
12 (Same as above.)
1432.84 (Monetary value, mistakenly entered by low IQ lackey. Delete.)
Right(Left(del(i, 1), 2), 6) is nonsensical.
The Left(del(i, 1), 2) part happens first and returns a 2-character string. If you then apply Right(..., 6) to that 2-character string you get an error.
The Mid function is needed here: Mid(del(i, 1), 3, 2)
Running the Abs function earlier changed the array entry from being a Variant with subtype String to being a Variant with subtype Double. This shouldn't necessarily affect the Left/Mid/Right functions but try:
del(i, 1) = CStr(del(i, 1))
del(i, 1) = DateSerial((Right(del(i, 1), 4)), (Left(del(i, 1), 2)), (Mid(del(i, 1), 3, 2)))
We need to identify what the actual value causing the error is so:
If delType = "Numeric" Then
If delChars = 8 Then
On Error Goto DateMismatchError
del(i, 1) = DateSerial((Right(del(i, 1), 4)), (Left(del(i, 1), 2)), (Mid(del(i, 1), 3, 2))) '<-- TYPE MISMATCH ERROR
On Error Goto 0
End If
End If
' at the end of your Sub or Function - I'm assuming Sub here
Exit Sub
DateMismatchError:
MsgBox "Date mismatch: error number " & Err.Number & ", " & Err.Description & _
" caused by data value: |" & del(i, 1) & "| at row " & i & ". Original data " & _
"value is |" & Range("AH" & i).Value2 & "|, displayed value is |" & _
Range("AH" & i).Text & "|, number format is |" & Range("AH" & i).NumberFormat & "|"
End Sub
You can use this shorter code to replace your array elements with formatted dates
It cuts down the amount of testing inside the loop to two IFs. If numeric test is run first - there is no point running a longer lenint test for strings that are not 8 characters
The string functions Left$, Mid$ etc are much quicker than their variant cousins Left, Mid etc
I have made a substituion for your importwsRowCount variable in the code below
Updated code to handle and dump results, now handles string tests and non-compliantnumbers as per barrowc comments
The code below puts the new dates into a second array, skipping the invalid dates
The second array is then dumped at `AI``
Sub ReCut2()
Dim del()
Dim X()
Dim lngCnt As Long
del = Range("AH1:Ah10").Value2
ReDim X(1 To UBound(del, 1), 1 To UBound(del, 2))
Dim delChars As Long
Dim delType As String
For lngCnt = LBound(del, 1) To UBound(del, 1)
If IsNumeric(del(lngCnt, 1)) Then
If Len(Int((del(lngCnt, 1)))) = 8 Then X(lngCnt, 1) = DateSerial(Right$(del(lngCnt, 1), 4), Left$(del(lngCnt, 1), 2), Mid$(del(lngCnt, 1), 3, 2))
End If
Next
[ai1].Resize(UBound(X, 1), UBound(X, 2)).Value2 = X
End Sub