I am not sure why but this cet = Split(strCSV, " - ") causes Run time error 5: Invalid procedure call or argument.
strCSV = Trim(cWk.Range("P" & i)): dt = CDate(CLng(cWk.Range("H" & i)))
where str = "Cap Style:Snapback - CD / Number:07 / Color:First Avenger(+S$1.50) / Box:none - Only Purchase 3 caps and above - Free Box "
Following code works perfectly on windows but it throws error on the above mentioned line
Option Explicit
Option Compare Text
Sub Get_Data()
Application.ScreenUpdating = False
Dim fName, wkB2 As Workbook, cWk As Worksheet, xWk As Worksheet, frowC As Long, i As Long, j As Long, ch As String, num As String
Dim strCSV As String, dt As Date, shtName As String, cet, temp As String, rng As Range, cel As Range, cl As String, rw As Long, toF As String
On Error GoTo Err
fName = Application.GetOpenFilename
If fName <> False Then
Set wkB2 = Workbooks.Open(fName): Set cWk = wkB2.Worksheets(1): frowC = cWk.Range("P" & Rows.Count).End(xlUp).Row
'Cap Style:Baseball - CC / Number:04 / Color:Grey(+S$2) / Box:none - Only Purchase 3 caps and above - Free Box
'Cap Style:SnapBack - CC / Number:04 / Color:Grey(+S$1.50) / Box:none - Only Purchase 3 caps and above - Free Box
For i = 2 To frowC
strCSV = Trim(cWk.Range("P" & i)): dt = CDate(CLng(cWk.Range("H" & i)))
If strCSV <> "" And IsDate(dt) Then
'ERROR cet = Split(strCSV, " - "): temp = cet(LBound(cet)): cet = Split(temp, ":"): shtName = Trim(cet(UBound(cet)))
For Each xWk In ThisWorkbook.Worksheets
If shtName = Trim(xWk.Name) Then
Set rng = xWk.Range("E3:BD3")
For Each cel In rng
If cel.Value = dt Then
cet = Split(cel.Address, "$"): cl = cet(UBound(cet) - 1): Exit For
End If
Next cel
cet = Split(strCSV, "Number:"): temp = cet(UBound(cet)): cet = Split(temp, "/"): num = Trim(cet(LBound(cet)))
cet = Split(strCSV, " / "): temp = cet(LBound(cet)): cet = Split(temp, " - "): ch = Trim(cet(UBound(cet))): ch = ch & "-" & num
Debug.Print "Ch is " & ch
Set rng = xWk.Range("A1:A" & xWk.Range("A" & Rows.Count).End(xlUp).Row)
For Each cel In rng
If cel.Value = ch Then
rw = cel.Row: Exit For
End If
Next cel
cet = Split(strCSV, "Color:"): temp = cet(UBound(cet)): cet = Split(temp, "("): toF = Trim(cet(LBound(cet)))
For j = rw To rw - 10 Step -1
If Trim(xWk.Range("B" & j)) = toF Then
rw = j: Exit For
End If
Next j
Debug.Print "Address is: " & cl & rw & " for row " & i
xWk.Range(cl & rw) = cWk.Range("O" & i)
Exit For
End If
Next xWk
End If
Next i
wkB2.Close False
Else
Exit Sub
End If
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub
Err:
MsgBox Err.Description
End Sub
Update: SplitString now handle multi-character delimiters.
We conclude that older versions of Mac Office use the equivalent of VB5. Since the Split function was introduced in VB6. An Invalid procedure call or argument is being thrown because the Split function is not available in VB5.
The workaround would be to create a custom function that works like Spli.
Split Replacement Function
Function SplitString(Text As String, Delimiter As String)
Dim arr() As String, s As String
Dim i As Long, iEnd As Long, iStart As Long, length As Long
length = Len(Delimiter)
ReDim Preserve arr(0)
iStart = 1
Do
iEnd = InStr(Mid(Text, iStart), Delimiter) - 1
If iEnd = -1 Then
ReDim Preserve arr(i)
arr(i) = Mid(Text, iStart)
Exit Do
Else
ReDim Preserve arr(i)
arr(i) = Mid(Text, iStart, iEnd)
iStart = iStart + iEnd + length
i = i + 1
End If
Loop Until iStart = 0
SplitString = arr
End Function
Here are the tests that I ran
Sub BatchTest()
Dim strCSV As String, Temp As String, Delimiter As String
Dim a
strCSV = "Cap Style Snapback - CD / Number 07 / Color First Avenger(+S$1.50) / Box none - Only Purchase 3 caps and above - Free Box"
a = SplitString(strCSV, "/")
TestSplit strCSV, " / "
TestSplit strCSV, " /"
TestSplit strCSV, "/"
TestSplit strCSV, " Color First"
End Sub
Sub TestSplit(Text As String, Delimiter As String)
Dim arr As Variant, sReplcement As String
arr = SplitString(Text, Delimiter)
sReplcement = Replace(Text, Delimiter, "|")
Debug.Print sReplcement
Debug.Print Join(arr, "|")
Debug.Print sReplcement = Join(arr, "|")
End Sub
The Results of the tests
Sub TestRegEx()
MsgBox RegexExtract("sdi 99090 dfddf sdi 5666", "(sdi \d+)", ", ") = "sdi 99090, sdi 5666"
End Sub
Function RegexExtract(ByVal text As String, _
ByVal extract_what As String, _
Optional seperator As String = "") As String
Dim i As Long, j As Long
Dim result As String
Dim allMatches As Object
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = extract_what
RE.Global = True
Set allMatches = RE.Execute(text)
For i = 0 To allMatches.count - 1
For j = 0 To allMatches.Item(i).submatches.count - 1
result = result & seperator & allMatches.Item(i).submatches.Item(j)
Next
Next
If Len(result) <> 0 Then
result = Right(result, Len(result) - Len(seperator))
End If
RegexExtract = result
End Function
Related
There's a few posts on this, but none seem to provide a whole code solution, so I'm posting this up, which is culled (and credited where appropriate) from various bits and pieces of ideas on the Internet. VB6 doesn't have any function to convert from a fraction to a decimal number, which I needed for a project that I was working on which was concerned with meal recipes. I considered writing a DLL in .NET and plugging it into my application, but decided on this approach in the end. I hope this is useful for others. The solution below will do the following:
You supply a decimal number and you will be returned the fraction as a string.
You supply a fraction as a string and you will be returned with the decimal number.
In both cases, whole numbers are accounted for eg. "2 3/4" (two and three quarters) or "2.75".
I'm sure the code is not efficient, so any improvements are welcome.
Copy/Paste this as a new Class module:
Option Explicit
Private ErrorNote As String
'Properties
Public Property Get GetAsFraction(numToConvert As Double) As String
On Error GoTo GetAsFraction_Error
GetAsFraction = FncGetAsFraction(numToConvert)
On Error GoTo 0
Exit Property
GetAsFraction_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'GetAsFraction' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Property
Public Property Get GetAsDecimal(fractionString As String) As Double
On Error GoTo GetAsDecimal_Error
GetAsDecimal = FncGetAsDecimal(fractionString)
On Error GoTo 0
Exit Property
GetAsDecimal_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'GetAsDecimal' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Property
'Functions - private
Private Function FncGetAsDecimal(fractionToConvert As String) As Double
Dim result As Double
Dim wholeNumber As Integer
Dim splitStr As Variant
Dim numerator As Integer
Dim denominator As Integer
Dim fractionString As String
Dim dividedByPos As Integer
On Error GoTo FncGetAsDecimal_Error
splitStr = Split(fractionToConvert, " ")
If UBound(splitStr) = 1 Then
wholeNumber = splitStr(0)
fractionString = splitStr(1)
Else
fractionString = splitStr(0)
End If
dividedByPos = InStr(1, fractionString, "/")
numerator = Left(fractionString, dividedByPos - 1)
denominator = Mid(fractionString, dividedByPos + 1)
result = Val(numerator) / Val(denominator) + wholeNumber
FncGetAsDecimal = result
On Error GoTo 0
Exit Function
FncGetAsDecimal_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncGetAsDecimal' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Function
Private Function FncGetAsFraction(numToConvert As Double) As String
Dim result As String
Dim numeratorCount As Integer
Dim denominator As Single
Dim multiplierStr As String
Dim i As Integer
Dim fractionNum As Single
Dim lowestCommonDenominator As Long
Dim wholeNumber As Integer
Dim decimalPos As Integer
On Error GoTo FncGetAsFraction_Error
If numToConvert > 0 Then
decimalPos = InStr(1, CStr(numToConvert), ".")
If decimalPos > 1 Then
wholeNumber = CStr(Mid(numToConvert, 1, decimalPos - 1))
numToConvert = CStr(Mid(numToConvert, decimalPos))
End If
numeratorCount = FncCountDecimalPlaces(numToConvert)
multiplierStr = "1"
For i = 1 To numeratorCount
multiplierStr = multiplierStr & "0"
Next i
fractionNum = numToConvert * Val(multiplierStr)
denominator = 1 * Val(multiplierStr)
result = FncCrunchFraction(fractionNum, denominator)
If result = "" Then result = fractionNum & "/" & denominator
If wholeNumber <> 0 Then result = wholeNumber & " " & result
Else
result = "ERROR"
End If
FncGetAsFraction = result
On Error GoTo 0
Exit Function
FncGetAsFraction_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncGetAsFraction' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Function
Private Function FncCountDecimalPlaces(num As Double) As Integer
Dim result As Integer
Dim numberStr As String
Dim i As Integer
Dim decimalPointPos As Integer
On Error GoTo FncCountDecimalPlaces_Error
numberStr = CStr(num)
If Len(numberStr) > 0 Then
i = 1
Do While i <= Len(numberStr) And decimalPointPos = 0
If Mid(numberStr, i, 1) = "." Then decimalPointPos = i
i = i + 1
Loop
End If
If i > 1 Then
result = (Len(numberStr) - i + 1)
End If
FncCountDecimalPlaces = result
On Error GoTo 0
Exit Function
FncCountDecimalPlaces_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncCountDecimalPlaces' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Function
'Credit to:
'http://www.tek-tips.com/viewthread.cfm?qid=206890
'dsi (Programmer) - 7 Feb 02 10:38
Private Function FncCrunchFraction(num1 As Single, num2 As Single) As String
Dim num As Single
Dim dem As Single
Dim cnt1 As Integer
Dim cnt2 As Integer
Dim numFactors() As Single
Dim demFactors() As Single
Dim common As Single
Dim i As Integer
Dim j As Integer
On Error GoTo FncCrunchFraction_Error
num = num1
dem = num2
For i = 2 To Int(num / 2) Step 1
If (num Mod i = 0) Then
cnt1 = cnt1 + 1
ReDim Preserve numFactors(1 To cnt1)
numFactors(cnt1) = i
End If
Next i
cnt1 = cnt1 + 1
ReDim Preserve numFactors(1 To cnt1)
numFactors(cnt1) = num
For i = 2 To Int(dem / 2) Step 1
If (dem Mod i = 0) Then
cnt2 = cnt2 + 1
ReDim Preserve demFactors(1 To cnt2)
demFactors(cnt2) = i
End If
Next i
cnt2 = cnt2 + 1
ReDim Preserve demFactors(1 To cnt2)
demFactors(cnt2) = dem
For i = cnt1 To 1 Step -1
For j = cnt2 To 1 Step -1
If (numFactors(i) = demFactors(j)) Then
common = numFactors(i)
FncCrunchFraction = num / common & "/" & dem / common
Exit Function
End If
Next j
Next i
FncCrunchFraction = ""
On Error GoTo 0
Exit Function
FncCrunchFraction_Error:
ErrorNote = "Line:" & Erl & " Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncCrunchFraction' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Function
Then call it with these code examples:
Public Function DecimalToFraction(number As Double) As String
Dim myFractionDecimal As New ClsFractionDecimal
DecimalToFraction = myFractionDecimal.GetAsFraction(number)
Set myFractionDecimal = Nothing
End Function
Public Function FractionToDecimal(fractionString As String) As Double
Dim myFractionDecimal As New ClsFractionDecimal
FractionToDecimal = myFractionDecimal.GetAsDecimal(fractionString)
Set myFractionDecimal = Nothing
End Function
I am trying to read in a JPG file and convert the file to a base64 encoded string that can be used as an embedded jpeg on a web page. I found two functions on the web for base64 encoding/decoding in VBA that appear to be well-accepted. The encode/decode process yields my original binary string, so the functions appear to be at least somewhat correct. However the base64 string I am getting is no where near what I get when I use an online tool to convert my image to base64.
The base64 string should start: "/9j/4AAQSkZJRgABAQEAUgBSAAD". Instead it is starting with: "Pz8/Pz9BYT8/AD8/Pz8/Pz8/Pz8/Pz8/Pz8". I'm lost as to why I'm not getting the former result and why I'm getting the latter. Am I doing something wrong in my reading of the binary file?
Here is my code:
Sub TestBase64()
Dim bytes, b64
With CreateObject("ADODB.Stream")
.Open
.Type = ADODB.adTypeBinary
.LoadFromFile "c:\temp\TestPic.jpg"
bytes = .Read
.Close
End With
Debug.Print bytes
b64 = Base64Encode(bytes)
Debug.Print vbCrLf + vbCrLf
Debug.Print b64
Debug.Print vbCrLf + vbCrLf
Debug.Print Base64Decode(CStr(b64))
End Sub
' Decodes a base-64 encoded string (BSTR type).
' 1999 - 2004 Antonin Foller, http://www.motobit.com
' 1.01 - solves problem with Access And 'Compare Database' (InStr)
Function Base64Decode(ByVal base64String)
'rfc1521
'1999 Antonin Foller, Motobit Software, http://Motobit.cz
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim dataLength, sOut, groupBegin
'remove white spaces, If any
base64String = Replace(base64String, vbCrLf, "")
base64String = Replace(base64String, vbTab, "")
base64String = Replace(base64String, " ", "")
'The source must consists from groups with Len of 4 chars
dataLength = Len(base64String)
If dataLength Mod 4 <> 0 Then
Err.Raise 1, "Base64Decode", "Bad Base64 string."
Exit Function
End If
' Now decode each group:
For groupBegin = 1 To dataLength Step 4
Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
' Each data group encodes up To 3 actual bytes.
numDataBytes = 3
nGroup = 0
For CharCounter = 0 To 3
' Convert each character into 6 bits of data, And add it To
' an integer For temporary storage. If a character is a '=', there
' is one fewer data byte. (There can only be a maximum of 2 '=' In
' the whole string.)
thisChar = Mid(base64String, groupBegin + CharCounter, 1)
If thisChar = "=" Then
numDataBytes = numDataBytes - 1
thisData = 0
Else
thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
End If
If thisData = -1 Then
Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
Exit Function
End If
nGroup = 64 * nGroup + thisData
Next
'Hex splits the long To 6 groups with 4 bits
nGroup = Hex(nGroup)
'Add leading zeros
nGroup = String(6 - Len(nGroup), "0") & nGroup
'Convert the 3 byte hex integer (6 chars) To 3 characters
pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _
Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _
Chr(CByte("&H" & Mid(nGroup, 5, 2)))
'add numDataBytes characters To out string
sOut = sOut & Left(pOut, numDataBytes)
Next
Base64Decode = sOut
End Function
Function Base64Encode(inData)
'rfc1521
'2001 Antonin Foller, Motobit Software, http://Motobit.cz
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim cOut, sOut, i
'For each group of 3 bytes
For i = 1 To Len(inData) Step 3
Dim nGroup, pOut, sGroup
'Create one long from this 3 bytes.
nGroup = &H10000 * Asc(Mid(inData, i, 1)) + _
&H100 * MyASC(Mid(inData, i + 1, 1)) + MyASC(Mid(inData, i + 2, 1))
'Oct splits the long To 8 groups with 3 bits
nGroup = Oct(nGroup)
'Add leading zeros
nGroup = String(8 - Len(nGroup), "0") & nGroup
'Convert To base64
pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)
'Add the part To OutPut string
sOut = sOut + pOut
'Add a new line For Each 76 chars In dest (76*3/4 = 57)
'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
Next
Select Case Len(inData) Mod 3
Case 1: '8 bit final
sOut = Left(sOut, Len(sOut) - 2) + "=="
Case 2: '16 bit final
sOut = Left(sOut, Len(sOut) - 1) + "="
End Select
Base64Encode = sOut
End Function
Function MyASC(OneChar)
If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function
That's some lengthy way to encode. I prefer this:
You Need to add reference to Microsoft XML, v6.0 (or v3.0)
Sub TestBase64()
Dim bytes, b64
With CreateObject("ADODB.Stream")
.Open
.Type = ADODB.adTypeBinary
.LoadFromFile "c:\temp\TestPic.jpeg"
bytes = .Read
.Close
End With
Debug.Print bytes
b64 = EncodeBase64(bytes)
Debug.Print vbCrLf + vbCrLf
Debug.Print Left(b64, 100)
' Debug.Print vbCrLf + vbCrLf
' Debug.Print Base64Decode(CStr(b64))
End Sub
Private Function EncodeBase64(bytes) As String
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = bytes
EncodeBase64 = objNode.Text
Set objNode = Nothing
Set objXML = Nothing
End Function
Output (first few characters): /9j/4AAQSkZJRgABAQEAYABgAAD
How can I pass the data generated by the EliminaAcentos function to the
URLEncode function in this script?
The first function removes diacritics and the second function URL-encodes the data.
Function EliminaAcentos(texto)
Dim i, s1, s2
s1 = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÒÓÔÕÖÙÚÛÜàáâãäåçèéêëìíîïòóôõöùúûü"
s2 = "AAAAAACEEEEIIIIOOOOOUUUUaaaaaaceeeeiiiiooooouuuu"
If Len(texto) <> 0 Then
For i = 1 To Len(s1)
texto = Replace(texto, Mid(s1,i,1), Mid(s2,i,1))
Next
End If
EliminaAcentos = texto
End Function
Function URLEncode(ByVal str)
Dim strTemp, strChar
Dim intPos, intASCII
strTemp = ""
strChar = ""
For intPos = 1 To Len(str)
intASCII = Asc(Mid(str, intPos, 1))
If intASCII = 32 Then
strTemp = strTemp & "+"
ElseIf ((intASCII < 123) And (intASCII > 96)) Then
strTemp = strTemp & Chr(intASCII)
ElseIf ((intASCII < 91) And (intASCII > 64)) Then
strTemp = strTemp & Chr(intASCII)
ElseIf ((intASCII < 58) And (intASCII > 47)) Then
strTemp = strTemp & Chr(intASCII)
Else
strChar = Trim(Hex(intASCII))
If intASCII < 16 Then
strTemp = strTemp & "%0" & strChar
Else
strTemp = strTemp & "%" & strChar
End If
End If
Next
URLEncode = strTemp
End Function
WScript.Echo URLEncode(WScript.Arguments(0))
Basically there are two ways to go about it:
You can nest the call of EliminaAcentos in the call of URLEncode as #JosefZ suggested:
URLEncode(EliminaAcentos(WScript.Arguments(0)))
You can embed the call of EleminaAcentos in the body of the URLEncode function:
Function URLEncode(ByVal str)
Dim strTemp, strChar
Dim intPos, intASCII
strTemp = ""
strChar = ""
str = EliminaAcentos(str)
For intPos = 1 To Len(str)
...
Next
URLEncode = strTemp
End Function
Usually you'd pick the first option if there are situations where you call URLEncode and don't want diacritics removed, or if you don't control the implementation of URLEncode. If you always want URLEncode to remove diacritics and you control the function implementation you'd pick the second option.
Side note (also mentioned by #JosefZ): pass the parameter to EliminaAcentos by value, so the function call doesn't inadvertently modify the original value.
Function EliminaAcentos(ByVal texto)
...
End Function
I'm making form where i need to enter the time's for each period like.
Start time - End time
Start time - End time
Start time - End time
Those record's could be saved in listbox as in my example. On another form i have 3 labels
CurrentTime, TimePassed, TimeLeft, and a Timer which ticks in interval 1second. So the time in timepassed ticking up, time left ticking down, and current time show correct time while application is opened.
In final it looks like this
Private Sub cmdAdd_Click()
Call addp
End Sub
Function addp(Optional ByVal t As String)
Dim s As String, e As String
If t = "" Then s = Trim(InputBox("Start time (hh:mm AM/PM):")) Else: s = Trim(Split(t, "-")(0))
If s = "" Or InStr(1, s, " AM") = 0 And InStr(1, s, " PM") = 0 Then Exit Function
If chk(s) = False Then Exit Function
If t = "" Then e = Trim(InputBox(s & "-?" & vbCrLf & "End time:")) Else: e = Trim(Split(t, "-")(1))
If e = "" Or InStr(1, e, " AM") = 0 And InStr(1, e, " PM") = 0 Then Exit Function
If e = s Then Exit Function
If chk(e) = False Then Exit Function
If Format$(Split(s, "-")(0), "hh:mm AM/PM") > Format$(Split(e, "-")(0), "hh:mm AM/PM") Then Exit Function
If lstPeriods.List(0) <> "" Then
If Format$(Split(lstPeriods.List(lstPeriods.ListCount - 1), "-")(1), "hh:mm AM/PM") > Format$(Split(s, "-")(0), "hh:mm AM/PM") Then Exit Function
End If
lstPeriods.AddItem lstPeriods.ListCount + 1 & ". " & s & "-" & e
If frmMain.lblPeriod.Caption = "" Then Call snd(s & "-" & e, lstPeriods.ListCount)
End Function
For check
Function chk(ByVal st As String) As Boolean
st = Replace$(Replace$(st, " AM", ""), " PM", "")
If UBound(Split(st, ":")) <> 1 Then Exit Function
For i = 0 To 1
If IsNumeric(Split(st, ":")(i)) = False Then Exit Function
If Len(Split(st, ":")(i)) <> 2 Then Exit Function
If Split(st, ":")(i) < 0 Then Exit Function
Next
If Split(st, ":")(0) > 12 Then Exit Function
If Split(st, ":")(1) > 59 Then Exit Function
chk = True
End Function
The solution i gave is the only solution which beginner as i I had. And i know it's confusing and very slow. There is no way this can be finished by using trim/split/format because it require for a lot of modification.
Searching for easier solution.
Sp i need to compare the current time on computer with the time person enetered in textbox/listbox how can i do that .
To Run this code you need to add 5 Controls to the Form1
lblSystemTime = Label Control
lblTimeLeft = Label Control
lblTimePassed = Label Control
lblPeriod = Label Control
tmrSystemTime = Timer Control
Dim Periods()
Private Sub Form_Load()
Periods = Array( _
"06:00 PM-07:00PM", _
"07:01 PM-08:00PM", _
"09:00 PM-10:00PM", _
"1AM-2AM" _
)
End Sub
Private Sub tmrSystemTime_Timer()
lblSystemTime.Caption = FormatDateTime(Now, vbLongTime)
Dim OnPeriod As Integer
OnPeriod = GetPeriod()
If OnPeriod < 0 Then
lblTimeLeft.Caption = vbNullString
lblTimePassed.Caption = vbNullString
lblPeriod.Caption = "Unknown Period"
Else
lblPeriod = CStr(OnPeriod + 1) & ". period"
lblTimeLeft.Caption = "Time Left: " & Format( _
DateAdd("s", _
DateDiff("s", _
CDate(lblSystemTime.Caption), _
CDate(Split(Periods(OnPeriod), "-")(1))), _
CDate("0") _
), _
"nn:ss" _
)
lblTimePassed.Caption = "Time Passed: " & Format( _
DateAdd("s", _
DateDiff("s", _
CDate(Split(Periods(OnPeriod), "-")(1)), _
CDate(lblSystemTime.Caption)), _
CDate("0") _
), _
"nn:ss" _
)
End If
End Sub
Private Function GetPeriod() As Integer
Dim ICount As Integer
For Each Pr In Periods
If CDate(Split(Pr, "-")(0)) <= CDate(lblSystemTime.Caption) And _
CDate(Split(Pr, "-")(1)) >= CDate(lblSystemTime.Caption) Then
GetPeriod = ICount
Exit Function
End If
ICount = ICount + 1
Next
GetPeriod = -1
End Function
Here is something which may help:
Private Sub TimeCheck(byval int_TimeNow as Integer)
dim intTimeThen as string 'set a variable to compare for the THEN time
dim intTimeNow as string 'set a variable to compare for the NOW time
dim intDiff as string ' set a variable for the difference in time
intTimeNow = int_TimeNow 'just to ensure we don't mess with any data
intTimeThen = val(txtTimeThen.text) 'get the numeric value of the time, the system will
'convert it from a string to the value here.
intDiff = intTimeThen - intTimeNow 'Do the math
lstTimeEvents.additem timevalue(intDiff) 'write it to a listbox
End Sub
I realize this is not the coding convention you are using, but it should demonstrate what you are looking for to some degree.
I have found some code on the Internet for listing out Outlook Profile Info and I would like to it, but it gives the error: Type mismatch:'[string: "A"]', at line 74 (code 800A000D). I don't know why it's not working.
Here is the code:
Option Explicit
Const HKEY_CURRENT_USER = &H80000001
Const r_PSTGuidLocation = "01023d00"
Const r_MasterConfig = "01023d0e"
Const r_PSTCheckFile = "00033009"
Const r_PSTFile = "001f6700"
Const r_keyMaster = "9207f3e0a3b11019908b08002b2a56c2"
Const r_ProfilesRoot = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
Const r_DefaultProfileString = "DefaultProfile"
Dim oReg:Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName
oReg.GetStringValue HKEY_CURRENT_USER,r_ProfilesRoot,r_DefaultProfileString,DefaultProfileName
GetPSTsForProfile(DefaultProfileName)
'_____________________________________________________________________________________________________________________________
Function GetPSTsForProfile(p_profileName)
Dim strHexNumber, strPSTGuid, strFoundPST
oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue
If IsUsableArray (strValue) Then
For Each i In strValue
If Len(Hex(i)) = 1 Then
strHexNumber = CInt("0") & Hex(i)
Else
strHexNumber = Hex(i)
End If
strPSTGuid = strPSTGuid + strHexNumber
If Len(strPSTGuid) = 32 Then
If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then
Wscript.Echo PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _
PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid))
End If
strPSTGuid = ""
End If
Next
End If
End Function
'______________
'_____________________________________________________________________________________________________________________________
Function GetSize(zFile)
Dim objFSO:Set objFSO = CreateObject("Scripting.FileSystemObject")
dim objFile:Set objFile = objFSO.GetFile(zFile)
GetSize = ConvertSize(objFile.Size)
End Function
'_____________________________________________________________________________________________________________________________
Function ConvertSize(Size)
Do While InStr(Size,",") 'Remove commas from size
CommaLocate = InStr(Size,",")
Size = Mid(Size,1,CommaLocate - 1) & _
Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate)
Loop
Dim Suffix:Suffix = " Bytes"
If Size >= 1024 Then suffix = " KB"
If Size >= 1048576 Then suffix = " MB"
If Size >= 1073741824 Then suffix = " GB"
If Size >= 1099511627776 Then suffix = " TB"
Select Case Suffix
Case " KB" Size = Round(Size / 1024, 1)
Case " MB" Size = Round(Size / 1048576, 1)
Case " GB" Size = Round(Size / 1073741824, 1)
Case " TB" Size = Round(Size / 1099511627776, 1)
End Select
ConvertSize = Size & Suffix
End Function
'_____________________________________________________________________________________________________________________________
Function IsAPST(p_PSTGuid)
Dim x, P_PSTGuildValue
Dim P_PSTCheck:P_PSTCheck=0
IsAPST=False
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTCheckFile,P_PSTGuildValue
If IsUsableArray (P_PSTGuildValue) Then
For Each x in (P_PSTGuildValue)
P_PSTCheck = P_PSTCheck + Hex(x)
Next
End If
If P_PSTCheck=20 Then IsAPST=True
End Function
'_____________________________________________________________________________________________________________________________
Function PSTlocation(p_PSTGuid)
Dim y, P_PSTGuildValue
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue
If IsUsableArray (P_PSTGuildValue) Then
For Each y In P_PSTGuildValue
If Len(Hex(y)) = 1 Then
PSTlocation = PSTlocation & CInt("0") & Hex(y)
Else
PSTlocation = PSTlocation & Hex(y)
End If
Next
End If
End Function
'_____________________________________________________________________________________________________________________________
Function PSTFileName(p_PSTGuid)
Dim z, P_PSTName
Dim strString : strString = ""
oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName
If IsUsableArray (P_PSTName) Then
For Each z in P_PSTName
If z > 0 Then strString = strString & Chr(z)
Next
End If
PSTFileName = strString
End Function
'_________________________________________________________________________________________________________
Function ExpandEvnVariable(ExpandThis)
Dim objWSHShell:Set objWSHShell = CreateObject("WScript.Shell")
ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%")
End Function
'_________________________________________________________________________________________________________
Function IsUsableArray(rvnt)'-- Use this function to test for a Null, Empty or an undimensioned array.'-- Useful b/c some interfaces can hold properties for which if they have a'-- value will be an Array but may also be Null or an undimensioned Array.
'-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned. '-- It returns -1 if it is passed a string, long, etc...'-- It returns 0 for an empty array or the number of elements in the first dimension.
IsUsableArray = 0
If (VarType(rvnt) And 8192) = 8192 Then
IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1
Else
If Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then IsUsableArray = -1
End If
End Function
The script works on my system if i correct the extra space at line 8 (Windows Messaging Subsystem)
It is a big script for what it offers, see here for a smaller one which offers more using the free to download library Redemption at http://www.dimastr.com/redemption/home.htm which is what CDO should have been.
set Session = CreateObject("Redemption.RDOSession")
const skUnknown = 0, olStoreANSI = 1, olStoreUnicode = 2, skPrimaryExchangeMailbox = 3, skPublicFolders = 5, skDelegateExchangeMailbox = 4
Session.Logon
for each Store in Session.Stores
if (Store.StoreKind = olStoreANSI) then
wscript.echo Store.Name & " - " & Store.PstPath & " " & Store.Name
elseif (Store.StoreKind = olStoreUnicode) Then
wscript.echo Store.Name & " - " & Store.PstPath
ElseIf (Store.StoreKind = skPrimaryExchangeMailbox) or (Store.StoreKind = skDelegateExchangeMailbox) or (Store.StoreKind = skPublicFolders) Then
wscript.echo Store.Name & " - " & Store.ServerDN
Else
wscript.echo Store.Name & " - " & Store.StoreKind
End If
next