We have some code that checks each incoming file against 3 different criteria before processing (Not a weekend, not after 6pm, not a holiday). This being said, I need to figure out how to have it check for a half hour now (bolded part). I have tried adding a + mRelease > 30 as well as AND mRelease > 30 and both have failed. I have been altering this line
Do While (WeekDay(dRelease) = 1) OR (WeekDay(dRelease) = 7) OR (UBound(fHoliday) > -1) OR (tRelease >17)
Here is the code currently in place:
result = ""
dRelease = Now
tRelease = CStr(Hour(Now))
mRelease = CStr(Minute(Now))
aHoliday = Array("01/02/2017","01/16/2017","05/29/2017","07/04/2017","09/04/2017","10/09/2017","11/23/2017","11/24/2017","12/25/2017","12/26/2017")
dNow = CStr(DatePart("m",Date)) + "/" + CStr(DatePart("d",Date)) + "/" + CStr(DatePart("yyyy",Date))
dMonth = "0" + CStr(Month(dRelease))
dDay = "0" + CStr(Day(dRelease))
dYear = CStr(Year(dRelease))
fHoliday = Filter(aHoliday,Right(dMonth,2) + "/" + Right(dDay,2) + "/" + dYear)
'fHoliday = Filter(aHoliday,dNow)
'result = UBound(fHoliday)
'result = Left(dRelease,10)
'result = CStr(DatePart("m",Date)) + "/" + CStr(DatePart("d",Date)) + "/" + CStr(DatePart("yyyy",Date))
'While release date is a weekend, or release date is a holiday
Do While (WeekDay(dRelease) = 1) OR (WeekDay(dRelease) = 7) OR (UBound(fHoliday) > -1) OR (tRelease >17)
'increase release date by 1
dRelease = dRelease + 1
'result = dRelease
'check for holiday
dMonth = "0" + CStr(Month(dRelease))
dDay = "0" + CStr(Day(dRelease))
dYear = CStr(Year(dRelease))
'fHoliday = Filter(aHoliday,Left(dRelease,10))
fHoliday = Filter(aHoliday,Right(dMonth,2) + "/" + Right(dDay,2) + "/" + dYear)
tRelease = 00
Loop
'Format the release date to the Esker deferred date/time standard.
dMonth = "0" + CStr(Month(dRelease))
dDay = "0" + CStr(Day(dRelease))
dYear = CStr(Year(dRelease))
dtCurrent = Right(dMonth,2) + "/" + Right(dDay,2) + "/" + dYear
If dRelease > Now Then
tRelease = "00:" + mRelease
Else
tRelease = CStr(Hour(Now)) + ":" + CStr(Minute(Now))
End If
result = dtCurrent + " " + tRelease
Change this:
Do While (WeekDay(dRelease) = 1) OR (WeekDay(dRelease) = 7) OR (UBound(fHoliday) > -1) OR (tRelease >17)
...
Loop
into this:
If (WeekDay(dRelease) = 1) Or (WeekDay(dRelease) = 7) Or (UBound(fHoliday) > -1) Or (Time > CDate("16:30")) Then
...
End If
Related
I'm making an antivirus. Now I want my antivirus to change color, so I'm making a form and .ini file (A save). So after a long time coding with Modules and functions. I wan tot test it out until I click the setting form button. I have a subscript out of range error(9).
Private Sub GetSetting(Path As String)
Dim Line As String, tmp() As String, ValueX(10) As String, a As Byte
a = 0
If IsFileX(Path) = True Then
Open Path For Input As #1
Do
Line Input #1, Line
tmp = Split(Line, "=")
If UBound(tmp) = 1 Then
a = a + 1
ValueX(a) = tmp(1)
Ck1.value = CInt(Left(Replace(ValueX(a), " ", ""), 1))
End If
If UBound(tmp) = 1 Then
a = a + 2
ValueX(a) = tmp(1)
Ck2.value = CInt(Left(Replace(ValueX(a), " ", ""), 1))
End If
If UBound(tmp) = 1 Then
a = a + 3
ValueX(a) = tmp(1)
Ck3.value = CInt(Left(Replace(ValueX(a), " ", ""), 1))
End If
If UBound(tmp) = 1 Then
a = a + 4
ValueX(a) = tmp(1)
Ck4.value = CInt(Left(Replace(ValueX(a), " ", ""), 1))
End If
If UBound(tmp) = 1 Then
a = a + 5
ValueX(a) = tmp(1)
Ck5.value = CInt(Left(Replace(ValueX(a), " ", ""), 1))
End If
If UBound(tmp) = 1 Then
a = a + 6
ValueX(a) = tmp(1)
Ck6.value = CInt(Left(Replace(ValueX(a), " ", ""), 1))
End If
Loop Until EOF(1)
Close #1
Else
MsgBox " Read Antivirus Setting is ERROR !" & vbNewLine & "Because the file [ MurderAV.ini ] is not found!", vbCritical, "MurderAV Error"
End If
End Sub
The Highlighted part is the ValueX(a) in ck5. (Ck is checkbox)
I'll photo it so it can be clearer:
The problem is that each If statement has an identical condition:
If UBound(tmp) = 1 Then
So, as you go through the code, you execute:
a = 0
a = a + 1
a = a + 2
a = a + 3
a = a + 4
a = a + 5
So a is 15, so you have:
ValueX(15) = tmp(1)
But since ValueX(10) As String, you are off the end of the array.
I'm building an encryption/decryption function in VBScript / Classic ASP.
It all works as long as the string to be encrypted/decrypted does not contain special characters.
' str = "Bayern München"
' key = "ab34ehyd67hy6752daskjh"
Function EncryptString(val, key)
valLen = Len(val)
keyLen = Len(key)
keyPos = 1
newVal = ""
revVal = val
For x = 1 To valLen
calc = AscW(Mid(revVal, x, 1)) + AscW(Mid(key, keyPos, 1))
'Response.Write ":" & AscW(Mid(revVal, x, 1)) & " + " & AscW(Mid(key, keyPos, 1)) & " = " & calc & "<br />"
newVal = newVal & Hex(calc)
keyPos = keyPos + 1
If keyPos > keyLen Then keyPos = 1
Next
EncryptString = newVal
End Function
Function DecryptString(val, key)
' The workaround - start
For i = 160 To 255
val = Replace(val, Chr(i), "&#" & i & ";")
Next
' The workaround - end
valLen = Len(val)
keyLen = Len(key)
keyPos = 1
newVal = ""
revVal = val
chrVal = ""
' I suspect this to be the error
For y = 1 To valLen Step 2
chrVal = chrVal & ChrW("&h" & Mid(revVal, y, 2))
Next
For x = 1 To Len(chrVal)
calc = AscW(Mid(chrVal, x, 1)) - AscW(Mid(key, keyPos, 1))
'Response.Write "::" & AscW(Mid(chrVal, x, 1)) & " - " & AscW(Mid(key, keyPos, 1)) & " = " & calc & "<br />"
newVal = newVal & ChrW(calc)
keyPos = keyPos + 1
If keyPos > keyLen Then keyPos = 1
Next
DecryptString = newVal
End Function
If I do an encryption of the string "Bayern München" and afterwards call the DecryptString function on the encrypted string, it returns Bayern M?À?vU?.
If I output the data (the Response.Write's in the example), the decryption function returns a negative number for the character ü, so I'm doing something wrong - but what?
The system encoding is Windows-1252.
UPDATE:
I did this workaround in the DecryptString function. I'm not sure if it covers all possible problems, but from my testing so far it does:
For i = 160 To 255
val = Replace(val, Chr(i), "&#" & i & ";")
Next
Don't know if you still need to fix it, but all above is because hex() returns a string longer than 2 for any decimal over 255:
(255)10 = (FF)16
(256)10 = (100)16
i.e. when original string + salt is over 255(10)
("ü" 252) + ("6" 54) = 252+54 = 306(10)=132(16) (3 characters long)
then "For y=1 To valLen Step 2" will take only "13" of "132" which will result to improper decryption.
Depends on the need, it can be "fixed", for example, by checking if encrypted code is over 255 and when true, do not add salt:
Function EncryptString(val, key)
...
'newVal = newVal & Hex(calc) <-- replace this by following code
if calc > 255 then
newVal = newVal & "01" & Hex(Asc(Mid(revVal, x, 1))) ' no salt
else
newVal = newVal & Hex(calc)
end if
where "01" is just a "signal" character that tells that the next char will be without salt.
Respectively,
Function DecryptString(val, key)
...
'calc = Asc(Mid(chrVal, x, 1)) - Asc(Mid(key, keyPos, 1))
if Asc(Mid(chrVal, x, 1))=1 then 'determine "signal"
ignorenext = true 'flag that next char has no salt
else
if ignorenext then
calc = Asc(Mid(chrVal, x, 1)) 'no salt
ignorenext = false
else
calc = Asc(Mid(chrVal, x, 1)) - Asc(Mid(key, keyPos, 1))
end if
newVal = newVal & Chr(calc)
keyPos = keyPos + 1
If keyPos > keyLen Then keyPos = 1
end if
Note, for Windows-1252 no need to use AscW()/ChrW() which are unicode specific.
Another approach will be to replace hexadecimal by something more "stable" i.e. base32. Taking sample code from Classic ASP/VBScript implementation of Crockford's Base32 Encoding your code can look like
Function EncryptString(val, key)
valLen = Len(val)
keyLen = Len(key)
keyPos = 1
newVal = ""
revVal = val
For x = 1 To valLen
calc = Asc(Mid(revVal, x, 1)) + Asc(Mid(key, keyPos, 1))
newVal = newVal & ToBase32(calc)
keyPos = keyPos + 1
If keyPos > keyLen Then keyPos = 1
Next
EncryptString = ucase(newVal)
End Function
Function DecryptString(val, key)
valLen = Len(val)
keyLen = Len(key)
keyPos = 1
newVal = ""
revVal = val
chrVal = ""
For y = 1 To valLen Step 2
chrVal = chrVal & fromBase32(Mid(revVal, y, 2))
calc = fromBase32(Mid(revVal, y, 2)) - Asc(Mid(key, keyPos, 1))
newVal = newVal & Chr(calc)
keyPos = keyPos + 1
If keyPos > keyLen Then keyPos = 1
Next
DecryptString = newVal
End Function
I want to revert the loop to 1 but only in .cmdTable(i).caption = txtPrefix.Text + Str(i) so the name + the number will revert back to 1 because every time a transact it will get the continues number of the loop
I want that Str(i) revert back to 1 on every time i click OK
For example i set the name of the table = TABLE + the number txtEndTable.Text = 5 it will loop from TABLE 1 to TABLE 5 for the second transaction name of the table = MARK + the number txtEndTable.Text = 5 it will generate MARK 6 to MARK 10. I want to get the MARK 1 to MARK 5 for second transaction
Any idea will do
Public Sub pAddMultipleTables()
Dim i As Integer
Dim x As Long
Dim lcDefaultTop As Integer
Dim lcLastLeft As Integer
Dim lcMax As Integer
Dim lcSpacing As Integer
Dim lcCurrentTable As Integer
Dim lcStart As Integer
lcSpacing = 1200
lcDefaultTop = 1300
lcMax = 5
lcCurrentTable = 1
lcLastLeft = 240
lcStart = 0
x = 0
With frmTableMap
For i = .cmdTable.ubound + 1 To .cmdTable.ubound + txtEndTable.Text
Load .cmdTable(i)
.cmdTable(i).Visible = True
If lcCurrentTable < lcMax Then
If lcCurrentTable = 1 Then
.cmdTable(i).Top = lcDefaultTop
Else
.cmdTable(i).Top = (.cmdTable(i - 1).Top + .cmdTable(i - 1).Height) + 120
End If
.cmdTable(i).Left = lcLastLeft
lcCurrentTable = lcCurrentTable + 1
' Add to database
.cmdTable(i).ZOrder 0
If optSquare.Value = True Then
.cmdTable(i).ButtonShape = 0
Else
.cmdTable(i).ButtonShape = 4
End If
.cmdTable(i).Caption = txtPrefix.Text + Str(i)
bRS.AddNew
bRS!Name = txtPrefix.Text + Str(i)
bRS!buttonorder = .cmdTable(i).Index
bRS!section = .lblSection.Caption
bRS!ForeColor = .cmdTable(i).ForeColor
bRS!FontSize = .cmdTable(i).Font.Size
bRS!Width = .cmdTable(i).Width
bRS!Height = .cmdTable(i).Height
bRS!Top = .cmdTable(i).Top
bRS!Left = .cmdTable(i).Left
bRS!FontBold = .cmdTable(i).Font.Bold
bRS!FontName = .cmdTable(i).Font.Name
bRS!BackColor = .cmdTable(i).BackColor
bRS!Capacity = txtCapacity.Text
bRS!Type = "1"
If optSquare.Value = True Then
bRS!ButtonShape = 0
Else
bRS!ButtonShape = 4
End If
bRS.Update
ElseIf lcCurrentTable = lcMax Then
If i > 1 Then
.cmdTable(i).Top = (.cmdTable(i - 1).Top + .cmdTable(i - 1).Height) + 200
.cmdTable(i).Left = lcLastLeft
End If
lcLastLeft = (lcLastLeft + .cmdTable(i).Width) + 120
lcCurrentTable = 1
.cmdTable(i).ZOrder 0
If optSquare.Value = True Then
.cmdTable(i).ButtonShape = 0
Else
.cmdTable(i).ButtonShape = 4
End If
.cmdTable(i).Caption = txtPrefix.Text + Str(i)
bRS.AddNew
bRS!Name = txtPrefix.Text + Str(i)
bRS!buttonorder = .cmdTable(i).Index
bRS!section = .lblSection.Caption
bRS!ForeColor = .cmdTable(i).ForeColor
bRS!FontSize = .cmdTable(i).Font.Size
bRS!Width = .cmdTable(i).Width
bRS!Height = .cmdTable(i).Height
bRS!Top = .cmdTable(i).Top
bRS!Left = .cmdTable(i).Left
bRS!FontBold = .cmdTable(i).Font.Bold
bRS!FontName = .cmdTable(i).Font.Name
bRS!BackColor = .cmdTable(i).BackColor
bRS!Capacity = txtCapacity.Text
bRS!Type = "1"
If optSquare.Value = True Then
bRS!ButtonShape = 0
Else
bRS!ButtonShape = 4
End If
bRS.Update
End If
Next
End With
End Sub
-Thanks guys
This might not be the most elegant solution but something like this might work.
For i = .cmdTable.lbound + 1 To .cmdTable.ubound + CInt(txtEndTable.Text)
https://msdn.microsoft.com/en-us/library/t9a7w1ac(v=vs.90).aspx
How to parse a time (month/date/year) in Microsoft QBasic, needed for testing.
s = 'PT1H28M26S'
I would like to get:
num_mins = 88
You can parse such a time string with the code below, but the real question is:
Who still uses QBasic in 2015!?
CLS
s$ = "PT1H28M26S"
' find the key characters in string
posP = INSTR(s$, "PT")
posH = INSTR(s$, "H")
posM = INSTR(s$, "M")
posS = INSTR(s$, "S")
' if one of values is zero, multiplying all will be zero
IF ((posP * posH * posM * posS) = 0) THEN
' one or more key characters are missing
nummins = -1
numsecs = -1
ELSE
' get values as string
sHour$ = MID$(s$, posP + 2, (posH - posP - 2))
sMin$ = MID$(s$, posH + 1, (posM - posH - 1))
sSec$ = MID$(s$, posM + 1, (posS - posM - 1))
' string to integer, so we can calculate
iHour = VAL(sHour$)
iMin = VAL(sMin$)
iSec = VAL(sSec$)
' calculate totals
nummins = (iHour * 60) + iMin
numsecs = (iHour * 60 * 60) + (iMin * 60) + iSec
END IF
' display results
PRINT "Number of minutes: "; nummins
PRINT "Number of seconds: "; numsecs
PRINT "QBasic in 2015! w00t?!"
Simpler way to grab minutes from string in qbasic
REM Simpler way to grab minutes from string in qbasic
S$ = "PT1H28M26S"
S$ = MID$(S$, 3) ' 1H28M26S
V = INSTR(S$, "H") ' position
H = VAL(LEFT$(S$, V - 1)) ' hours
S$ = MID$(S$, V + 1) ' 28M26S
V = INSTR(S$, "M") ' position
M = VAL(LEFT$(S$, V - 1)) ' minutes
PRINT "num_mins ="; H * 60 + M
I have this function which concatenates two matrices:
out->_11 = MAT_MUL(b->_11, a->_11) + MAT_MUL(b->_21, a->_12) + MAT_MUL(b->_31, a->_13) + MAT_MUL(b->_41, a->_14);
out->_12 = MAT_MUL(b->_12, a->_11) + MAT_MUL(b->_22, a->_12) + MAT_MUL(b->_32, a->_13) + MAT_MUL(b->_42, a->_14);
out->_13 = MAT_MUL(b->_13, a->_11) + MAT_MUL(b->_23, a->_12) + MAT_MUL(b->_33, a->_13) + MAT_MUL(b->_43, a->_14);
out->_14 = MAT_MUL(b->_14, a->_11) + MAT_MUL(b->_24, a->_12) + MAT_MUL(b->_34, a->_13) + MAT_MUL(b->_44, a->_14);
out->_21 = MAT_MUL(b->_11, a->_21) + MAT_MUL(b->_21, a->_22) + MAT_MUL(b->_31, a->_23) + MAT_MUL(b->_41, a->_24);
out->_22 = MAT_MUL(b->_12, a->_21) + MAT_MUL(b->_22, a->_22) + MAT_MUL(b->_32, a->_23) + MAT_MUL(b->_42, a->_24);
out->_23 = MAT_MUL(b->_13, a->_21) + MAT_MUL(b->_23, a->_22) + MAT_MUL(b->_33, a->_23) + MAT_MUL(b->_43, a->_24);
out->_24 = MAT_MUL(b->_14, a->_21) + MAT_MUL(b->_24, a->_22) + MAT_MUL(b->_34, a->_23) + MAT_MUL(b->_44, a->_24);
out->_31 = MAT_MUL(b->_11, a->_31) + MAT_MUL(b->_21, a->_32) + MAT_MUL(b->_31, a->_33) + MAT_MUL(b->_41, a->_34);
out->_32 = MAT_MUL(b->_12, a->_31) + MAT_MUL(b->_22, a->_32) + MAT_MUL(b->_32, a->_33) + MAT_MUL(b->_42, a->_34);
out->_33 = MAT_MUL(b->_13, a->_31) + MAT_MUL(b->_23, a->_32) + MAT_MUL(b->_33, a->_33) + MAT_MUL(b->_43, a->_34);
out->_34 = MAT_MUL(b->_14, a->_31) + MAT_MUL(b->_24, a->_32) + MAT_MUL(b->_34, a->_33) + MAT_MUL(b->_44, a->_34);
out->_41 = MAT_MUL(b->_11, a->_41) + MAT_MUL(b->_21, a->_42) + MAT_MUL(b->_31, a->_43) + MAT_MUL(b->_41, a->_44);
out->_42 = MAT_MUL(b->_12, a->_41) + MAT_MUL(b->_22, a->_42) + MAT_MUL(b->_32, a->_43) + MAT_MUL(b->_42, a->_44);
out->_43 = MAT_MUL(b->_13, a->_41) + MAT_MUL(b->_23, a->_42) + MAT_MUL(b->_33, a->_43) + MAT_MUL(b->_43, a->_44);
out->_44 = MAT_MUL(b->_14, a->_41) + MAT_MUL(b->_24, a->_42) + MAT_MUL(b->_34, a->_43) + MAT_MUL(b->_44, a->_44);
MAT_MUL looks like this:
#define MAT_MUL(o1,o2) ((GLfixed)((long)(o1)*(long)(o2))>>16)
The odd thing is that it doesn't work with fixed point values but with float values (MAT_MUL(o1,o2) (o1)*(o2) in this case). I traced the error down to this bit of code.
Any ideas? Thanks