Example code for illustration:
Option Explicit
Dim obj: Set obj = New Foo
WScript.Echo "EnvFlags(0)=" & obj.EnvFlags(0) 'EnvFlags(0)=False
WScript.Echo Join(obj.EnvFlags(-1), ",") 'False,False,False
On Error Resume Next 'enabled just for facility's sake
obj.EnvFlags 0, True '<< Why this NOT work?...
If Err Then WScript.Echo Err.Number, Err.Description
'> 450 Wrong number of arguments or invalid property assignment
On Error Goto 0
Class Foo
Private mEnvFlags
Public Property Let EnvFlags(nIndex, bValue)
If vbBoolean <> VarType(bValue) Then Exit Property
If nIndex >= 0 And nIndex <= 2 Then
mEnvFlags(nIndex) = bValue
End If
End Property
Public Property Get EnvFlags(nIndex)
If nIndex < 0 Or nIndex > 2 Then
EnvFlags = mEnvFlags
Else
EnvFlags = mEnvFlags(nIndex)
End If
End Property
Private Sub Class_Initialize
mEnvFlags = Array(False, False, False)
End Sub
End Class
How to fix that? (and as bonus - why it`s happen?) Thanks
Reference the documentation for Property Let. A Property Let is not the same as a subroutine call. The proper syntax is
obj.EnvFlags(0) = True
Related
I am somewhat new to vba, and I'm trying to create a somewhat more complex conditional format than access 2013 allows from the conditional formatting menu. I have a form with 22 target date and actual date fields. for each pair I need to:
if the target date is more than 7 days in the future, color it green.
If the target date is less than 7 days in the future or is today, color it yellow
If the target date in the past, color it red.
UNLESS there is an actual date it was accomplished, in which case:
If the actual date is before the target date, color both dates green
If the actual date is after the target date, color both dates red.
Because I have to do this on form load, and on the change of any date field (the target dates are calculated, but will change if other data is changed in the form), I wanted to write a public sub that takes form name, target date, and actual date as variables. I was able to code each box to do this on the local form module with 'Me.txtbox'
However, when I try to reference the form and text boxes from the public sub, it seems like I'm not properly referencing the text boxes on the form. I've tried 3 or 4 different ways of doing this (string, textbox.name, etc) and I feel like I'm close, but ...
Code that works as desired in the form module
Private Sub txtFreqReqDate_AfterUpdate()
If Me.txtFreqReqDate <= Me.txtFreqReq Then
Me.txtFreqReq.Format = "mm/dd/yyyy[green]"
Me.txtFreqReqDate.Format = "mm/dd/yyyy[green]"
ElseIf Me.txtFreqReqDate > Me.txtFreqReq Then
Me.txtFreqReq.Format = "mm/dd/yyyy[red]"
Me.txtFreqReqDate.Format = "mm/dd/yyyy[red]"
ElseIf IsNull(Me.txtFreReqDate) = True Then
If Me.txtFreqReq < Now() Then
Me.txtFreqReq.Format = "mm/dd/yyyy[red]"
ElseIf Me.txtFreqReq >= (Now()+7) Then
Me.txtFreqReq.Format = "mm/dd/yyyy[yellow]"
ElseIf Me.txtFreqReq > (Now()+7) Then
Me.txtFreqReq.Format = "mm/dd/yyyy[green]"
Else
Me.txtFreqReq.Format = "mm/dd/yyyy[black]"
End If
Else
Exit Sub
End If
End Sub
Perhaps not the prettiest, but I'm always open to constructive criticism. I'd have to write this 22+ times for each pair, changing the name of the text boxes each time. I want to write a public sub that just takes the names of the text boxes, but I can't seem to find the right combination:
Private Sub txtFreqReqDate_AfterUpdate()
FormatBoxes(Me, me.txtFreqReqDate, me.txtFreqReq)
End Sub
And in another module:
Public Sub FormatBoxes(CurrentForm As Form, txtActual as Textbox, txtTarget as Textbox)
frmName = CurrentForm.name
tbActual = txtActual.Name
tbTarget = txtTarget.Name
If frmName.tbActual <= frmName.tbTarget Then
frmName.tbTarget.Format = "mm/dd/yyyy[green]"
frmName.tbActual.Format = "mm/dd/yyyy[green]"
ElseIf frmName.tbActual > frmName.tbTarget Then
frmName.tbTarget.Format = "mm/dd/yyyy[red]"
frmName.tbActual.Format = "mm/dd/yyyy[red]"
ElseIf IsNull(frmName.tbActual) = True Then
If frmName.tbTarget < Now() Then
frmName.tbTarget.Format = "mm/dd/yyyy[red]"
ElseIf frmName.tbTarget >= (Now()+7) Then
frmName.tbTarget.Format = "mm/dd/yyyy[yellow]"
ElseIf frmName.tbTarget > (Now()+7) Then
frmName.tbTarget.Format = "mm/dd/yyyy[green]"
Else
frmName.tbTarget.Format = "mm/dd/yyyy[black]"
End If
Else
Exit Sub
End If
End Sub
Sorry if this is a bit long, I'm just at my wit's end...
Also, apologies for any typos. I had to re-type this from another machine.
You can simply use the textbox parameters directly in your sub.
It is not even necessary to pass the form as parameter.
Public Sub FormatBoxes(txtActual as Textbox, txtTarget as Textbox)
If txtActual.Value <= txtTarget.Value Then
txtTarget.Format = "mm/dd/yyyy[green]"
etc.
Note that when calling it, you need either Call or remove the parentheses.
Private Sub txtFreqReqDate_AfterUpdate()
Call FormatBoxes(me.txtFreqReqDate, me.txtFreqReq)
' or
' FormatBoxes me.txtFreqReqDate, me.txtFreqReq
End Sub
CurrentForm.name is a string. It is the Name property of the CurrentForm object. The CurrentForm object also has a controls collection in which the texboxes live. You can refer to them by name in there like CurrentForm.Controls("tbTarget") but you can also say CurrentForm.tbTarget. So you're very close and on the right track.
Change
frmName = CurrentForm.name
tbActual = txtActual.Name
tbTarget = txtTarget.Name
to
set frmName = CurrentForm
if frmName is not nothing then
set tbActual = txtActual
set tbTarget = txtTarget
end if
Alternatively if your signature on your method is
Public Sub FormatBoxes(CurrentForm As string, txtActual as string, txtTarget as string)
then your set up will look like
set frmName = forms(CurrentForm)
if frmName is not nothing then
set tbActual = frmName.controls(txtActual)
set tbTarget = frmName.controls(txtTarget)
end if
But I think the first one will work better.
I wanted to post the finished code to help out anyone else who searches for this subject. I did a couple thins to make this sub more universal.
First, Instead of using the date format, I only changed the .ForeColor, allowing me to use this sub for any type of textbox.
Public Sub FormatBoxes(txtActual As TextBox, txtTarget As TextBox, chkRequired As CheckBox, _
Optional intOption as Integer)
Dim intRed As Long, intYellow As Long, intGreen As Long, inBlack As Long, intGray As Long
intBlack = RGB(0, 0, 0)
intGray = RGB(180, 180, 180)
intGreen = RGB (30, 120, 30)
intYellow = RGB(217, 167, 25)
intRed = RGB(255, 0, 0)
If (chkRequired = False) Then
txtTarget.ForeColor = intGray
txtActual.ForeColor = intGray
If intOption <> 1 Then
txtTarget.Enabled = False
txtActual.Enabled = False
txtTarget.TabStop = False
txtActual.TabStop = False
End If
Else
If intOption <> 1 Then
txtTarget.Enabled = True
txtActual.Enabled = True
txtTarget.Locked = True
txtActual.Locked = False
txtTarget.TabStop = False
txtActual.TabStop = True
End If
If IsBlank(txtActual) = True Then
If txtTarget < Now() Then
txtTarget.ForeColor = intRed
ElseIf txtTarget > (Now() + 7) Then
txtTarget.ForeColor = intGreen
ElseIf txtTarget >= Now() And txtTarget <= (Now() +7) Then
txtTarget.ForeColor = intYellow
Else
txtTarget.ForeColor = intBlack
End If
ElseIf intOption - 1 Then
txtTarget.ForeColor = intBlack
txtActual.ForeColor = intBlack
ElseIf txtActual <= txtTarget Then
txtTarget.ForeColor = intGreen
txtActual.ForeColor = intGreen
ElseIf txtActual > txtTarget Then
txtTarget.ForeColor = intRed
txtActual.ForeColor = intRed
End If
End If
End Sub
In case you were wondering, IsBlank() is a function that checks for a null or zero length string:
Public Function IsBlank(str_in As Variant) As Long
If Len(str_in & "") = 0 Then
IsBlank = -1
Else
IsBlank = 0
End If
End Function
Thanks for all the help, and I hope this is useful for someone.
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
I'm trying to write a lottery application and have written out all the code. Everything seems to be fine except the part where it's supposed to show the winning numbers and the user's numbers. When the ResultsForm pops up, all the labels are blank instead of having the numbers filled in. Any help would be greatly appreciated. I will include the code for the MainForm, the ResultsForm and the Module I used.
Public Class MainForm
Dim rand As New Random
Private Sub MainForm_Load(ByVal sender As System.Object, ByVal e As System.EventArgs)
GenerateNewLotteryNumbers()
End Sub
Private Sub btnCheckNumbers_Click(sender As Object, e As EventArgs) Handles btnCheckNumbers.Click
If ValidateUserPicks() Then
DisplayResults()
End If
End Sub
Private Sub btnPlayAgain_Click(sender As Object, e As EventArgs) Handles btnPlayAgain.Click
GenerateNewLotteryNumbers()
Reset()
End Sub
Private Sub btnExit_Click(sender As Object, e As EventArgs) Handles btnExit.Click
Me.Close()
End Sub
Sub GenerateNewLotteryNumbers()
For intCount = 0 To g_intUPPER_SUB
g_intNumbers(intCount) = rand.Next(10)
Next
End Sub
Sub Reset()
txtDigit1.Clear()
txtDigit2.Clear()
txtDigit3.Clear()
txtDigit4.Clear()
txtDigit5.Clear()
txtDigit1.Focus()
End Sub
Sub DisplayResults()
Dim frmResults As New ResultsForm
frmResults.ShowDialog()
End Sub
Function ValidateUserPicks() As Boolean
Dim blnIsValid As Boolean = False
If Integer.TryParse(txtDigit1.Text, g_intUserPicks(0)) And
g_intUserPicks(0) >= 0 And g_intUserPicks(0) <= 9 Then
If Integer.TryParse(txtDigit2.Text, g_intUserPicks(1)) And
g_intUserPicks(1) >= 0 And g_intUserPicks(1) <= 9 Then
If Integer.TryParse(txtDigit3.Text, g_intUserPicks(2)) And
g_intUserPicks(2) >= 0 And g_intUserPicks(2) <= 9 Then
If Integer.TryParse(txtDigit4.Text, g_intUserPicks(3)) And
g_intUserPicks(3) >= 0 And g_intUserPicks(3) <= 9 Then
If Integer.TryParse(txtDigit5.Text, g_intUserPicks(4)) And
g_intUserPicks(4) >= 0 And g_intUserPicks(4) <= 9 Then
End If
blnIsValid = True
Else
MessageBox.Show("Digit 5: Enter a number between 0 and 9.")
txtDigit5.Focus()
txtDigit5.SelectAll()
End If
Else
MessageBox.Show("Digit 4: Enter a number between 0 and 9.")
txtDigit4.Focus()
txtDigit5.SelectAll()
End If
Else
MessageBox.Show("Digit 3: Enter a number between 0 and 9.")
txtDigit3.Focus()
txtDigit3.SelectAll()
End If
Else
MessageBox.Show("Digit 2: Enter a number between 0 and 9.")
txtDigit2.Focus()
txtDigit2.SelectAll()
End If
Return blnIsValid
End Function
End Class
ResultsForm:
Public Class ResultsForm
Private Sub ResultsForm_Load(ByVal sender As System.Object, ByVal e As System.EventArgs)
DisplayLotteryNumbers()
ShowResults()
End Sub
Private Sub btnOk_Click(sender As Object, e As EventArgs) Handles btnOk.Click
Me.Close()
End Sub
Sub DisplayLotteryNumbers()
lblWinningNumber1.Text = g_intNumbers(0).ToString
lblWinningNumber2.Text = g_intNumbers(1).ToString
lblWinningNumber3.Text = g_intNumbers(2).ToString
lblWinningNumber4.Text = g_intNumbers(3).ToString
lblWinningNumber5.Text = g_intNumbers(4).ToString
lblYourNumber1.Text = g_intNumbers(0).ToString
lblYourNumber2.Text = g_intNumbers(1).ToString
lblYourNumber3.Text = g_intNumbers(2).ToString
lblYourNumber4.Text = g_intNumbers(3).ToString
lblYourNumber5.Text = g_intNumbers(4).ToString
End Sub
Sub DisplayWinnerForm()
Dim frmWinner As New WinnerForm
frmWinner.ShowDialog()
End Sub
Sub ShowResults()
Select Case MatchingDigits()
Case 1
lblResults.Text = "One Matching Digit."
Case 2
lblResults.Text = "Two Matching Digits."
Case 3
lblResults.Text = "Three Matching Digits."
Case 4
lblResults.Text = "Four Matching Digits."
Case 5
lblResults.Text = "All Digits Match!"
DisplayWinnerForm()
Case Else
lblResults.Text = "No Matching Digits."
End Select
End Sub
Function MatchingDigits() As Integer
Dim numMatches As Integer
For intCount = 0 To g_intUPPER_SUB
If g_intNumbers(intCount) = g_intUserPicks(intCount) Then
numMatches += 1
End If
Next
Return numMatches
End Function
End Class
Module:
Module LotteryModule
Public Const g_intUPPER_SUB As Integer = 4
Public g_intNumbers(g_intUPPER_SUB) As Integer
Public g_intUserPicks(g_intUPPER_SUB) As Integer
End Module
Access 2010: I have a table that includes 3 Boolean fields - call them Field_A, Field_B, and Field_C.
On the data entry form, a user should be able to check (make the value TRUE) any one of those options, but only one option can be TRUE at any time. If Field_B is already true and the user wants to change it so Field_C is the option selected to be TRUE, he should first have to unselect Field_B (reset it to FALSE) before he can check the box on the form for Field_C.
So I need some validation code for each of these fields which, if the user tries to set one field to TRUE, checks the status of the other two fields. If both other fields are currently FALSE, it allows the current field to be changed to TRUE. But if either of the other fields is currently TRUE, it should create a popup message saying there's already another selection and the other field must first be changed to FALSE before he can proceed.
I tried this using the numerical values for the Yes/No option, setting a conditional validation that required the sum of the other two values to be zero before allowing the field of interest (e.g. Field_A) to be changed to TRUE (value = -1) (just something like ([Field_B] + [Field_C]) =0, but I kept getting syntax errors. I'm new enough to this that I don't know if it really is just a simple syntax problem, or if a completely different approach is needed.
Last piece of info-- it's acceptable to have all 3 fields set to FALSE, so I don't want something that forces one of them to become TRUE if another is changed back from TRUE to FALSE.
You have two acceptable combinations for those 3 check boxes:
all are False (unchecked)
only one can be True (checked)
So that means the sum of those check box values must be either 0 or -1.
? False + False + False
0
? False + False + True
-1
You can add a function in the form's code module ...
Private Function checkBoxProblem() As Boolean
Dim blnReturn As Boolean
Dim intSum As Integer
Dim strPrompt As String
intSum = Nz(Me.Field_A, 0) + Nz(Me.Field_B, 0) + Nz(Me.Field_C, 0)
If Not (intSum = 0 Or intSum = -1) Then
strPrompt = "only one box can be checked"
MsgBox strPrompt
blnReturn = True
Else
blnReturn = False
End If
checkBoxProblem = blnReturn
End Function
Then call the function from the before update events of each of those 3 check boxes.
Private Sub Field_A_BeforeUpdate(Cancel As Integer)
Cancel = checkBoxProblem
End Sub
Private Sub Field_B_BeforeUpdate(Cancel As Integer)
Cancel = checkBoxProblem
End Sub
Private Sub Field_C_BeforeUpdate(Cancel As Integer)
Cancel = checkBoxProblem
End Sub
A bit of code behind your data-entry form should do the trick. Try something along these lines:
Option Compare Database
Option Explicit
Private Sub Field_A_BeforeUpdate(Cancel As Integer)
Const ThisField = "Field_A"
If Me.Field_A.Value Then
If Me.Field_B.Value Then
ShowMyMessage "Field_B", ThisField
Cancel = True
ElseIf Me.Field_C.Value Then
ShowMyMessage "Field_C", ThisField
Cancel = True
End If
End If
End Sub
Private Sub Field_B_BeforeUpdate(Cancel As Integer)
Const ThisField = "Field_B"
If Me.Field_B.Value Then
If Me.Field_A.Value Then
ShowMyMessage "Field_A", ThisField
Cancel = True
ElseIf Me.Field_C.Value Then
ShowMyMessage "Field_C", ThisField
Cancel = True
End If
End If
End Sub
Private Sub Field_C_BeforeUpdate(Cancel As Integer)
Const ThisField = "Field_C"
If Me.Field_C.Value Then
If Me.Field_B.Value Then
ShowMyMessage "Field_B", ThisField
Cancel = True
ElseIf Me.Field_A.Value Then
ShowMyMessage "Field_A", ThisField
Cancel = True
End If
End If
End Sub
Private Sub ShowMyMessage(OtherField As String, CurrentField As String)
MsgBox _
"You must un-select """ & OtherField & """" & _
" before you can select """ & CurrentField & """", _
vbExclamation, _
"Mutually exclusive options conflict"
End Sub
I searched but couldn't find what I'm looking for.
How do I convert a normal Date() in ASP Classic to a string in the format dd-monthname-YYYY?
Here is an example:
Old date (mm/dd/YYYY) : 5/7/2013
New date (dd-monthname-YYYY) : 7-May-2013
Dim Dt
Dt = CDate("5/7/2013")
Response.Write Day(Dt) & "-" & MonthName(Month(Dt)) & "-" & Year(Dt)
' yields 7-May-2013
' or if you actually want dd-monthname-YYYY instead of d-monthname-YYYY
Function PadLeft(Value, Digits)
PadLeft = CStr(Value)
If Len(PadLeft) < Digits Then
PadLeft = Right(String(Digits, "0") & PadLeft, Digits)
End If
End Function
Response.Write PadLeft(Day(Dt), 2) & "-" & MonthName(Month(Dt)) & "-" & Year(Dt)
'yields 07-May-2013
I wrote an ASP Classic date handling object a while back that might be of use to you. It has a .Format() method that lets you pass in format specifiers just like the Format() function from VB/VBA. If there are any parts missing, I apologize--but this should be a giant leap forward toward natural date formatting.
Private pMillisecondMatch
Function RemoveMillisecondsFromDateString(DateString) ' Handle string dates from SQL Server that have milliseconds attached
If IsEmpty(pMillisecondMatch) Then
Set pMillisecondMatch = New RegExp
pMillisecondMatch.Pattern = "\.\d\d\d$"
pMillisecondMatch.Global = False
End If
RemoveMillisecondsFromDateString = pMillisecondMatch.Replace(DateString, "")
End Function
Function DateConvert(DateValue, ValueIfError)
On Error Resume Next
If IsDate(DateValue) Then
DateConvert = CDate(DateValue)
Exit Function
ElseIf TypeName(DateValue) = "String" Then
DateValue = RemoveMillisecondsFromDateString(DateValue)
If IsDate(DateValue) Then
DateConvert = CDate(DateValue)
Exit Function
End If
End If
DateConvert = ValueIfError
End Function
Class AspDate
Private pValue
Public Default Property Get Value()
Value = pValue
End Property
Public Property Set Value(DateValue)
If TypeName(DateValue) = "AspDate" Then
pValue = DateValue.Value
Else
Err.Raise 60020, "Class AspDate: Invalid object type " & TypeName(DateValue) & " passed to Value property."
End If
End Property
Public Property Let Value(DateValue)
pValue = DateConvert(DateValue, Empty)
End Property
Public Property Get FormattedDate()
FormattedDate = Format("yyyy-mm-dd hh:nn:ss")
End Property
Public Function Format(Specifier)
Dim Char, Code, Pos, MonthFlag
Format = "": Code = ""
If IsEmpty(Value) Then
Format = "(Empty)"
End If
Pos = 0
MonthFlag = False
For Pos = 1 To Len(Specifier) + 1
Char = Mid(Specifier, Pos, 1)
If Char = Left(Code, 1) Or Code = "" Then
Code = Code & Char
Else
Format = Format & Part(Code, MonthFlag)
Code = Char
End If
Next
End Function
Private Function Part(Interval, MonthFlag)
Select Case LCase(Left(Interval, 1))
Case "y"
Select Case Len(Interval)
Case 1, 2
Part = Right(CStr(Year(Value)), 2)
Case 3, 4
Part = Right(CStr(Year(Value)), 4)
Case Else
Part = Right(CStr(Year(Value)), 4)
End Select
Case "m"
If Not MonthFlag Then ' this is a month calculation
MonthFlag = True
Select Case Len(Interval)
Case 1
Part = CStr(Month(Value))
Case 2
Part = Right("0" & CStr(Month(Value)), 2)
Case 3
Part = MonthName(Month(Value), True)
Case 4
Part = MonthName(Month(Value))
Case Else
Part = MonthName(Month(Value))
End Select
Else ' otherwise it's a minute calculation
Part = Right("0" & Minute(Value), 2)
End If
Case "n"
Part = Right("0" & Minute(Value), 2)
Case "d"
Part = CStr(Day(Value))
If Len(Part) < Len(Interval) Then
Part = Right("0" & Part, Len(Interval))
End If
Case "h"
MonthFlag = True
Part = CStr(Hour(Value))
If Len(Part) < Len(Interval) Then
Part = Right("0" & Part, Len(Interval))
End If
Case "s"
Part = Right("0" & Second(Value), 2)
Case Else ' The item is not a recognized date interval, just return the value
Part = Interval
End Select
End Function
End Class
Function NewDate(Value)
Set NewDate = New AspDate
NewDate.Value = Value
End Function
Function NewDateWithDefault(Value, DefaultValue)
Set NewDateWithDefault = New AspDate
If Value = Empty Then
NewDateWithDefault.Value = DefaultValue
Else
NewDateWithDefault.Value = Value
End If
End Function
Here's example code using the above class:
<%=NewDate(Checkin.Parameters.Item("#DOB").Value).Format("mm/dd/yyyy")%>
To get the format you've noted above, you would do:
.Format("d-mmmm-yyyy")