I'm trying to get the date from an attribute called 'accountExpires' of a computer object in Active Directory. If the object haven't been set it just says 'never' and if you look it just have a many numbers. I made this and it working for the attribute 'lastlogon', but not for 'accountExpires'. Maybe someone can help me out.
I'm using VBscript because our company is using this in our loginscript.
On Error Resume Next
Dim ADSysInfo, objComputer, lobjDate, laccountExpiresDate, WSHShell
Set WSHShell = CreateObject("WScript.Shell")
Set ADSysInfo = CreateObject("ADSystemInfo")
Set objComputer = GetObject("LDAP://" & ADSysInfo.ComputerName)
msgbox objComputer
Set lobjDate = objComputer.get("lastLogon") ' <----- Working ----->
' Set lobjDate = objComputer.get("accountExpires") ' <----- Not Working ----->
msgbox err.number
if IsNull(lobjDate) then
msgbox "No Date"
else
laccountExpiresDate = Integer8Date(lobjDate, getLocaltimeZoneBias)
msgbox laccountExpiresDate
end if
Function Integer8Date(objDate, lngBias)
' Function to convert Integer8 (64-bit) value to a date, adjusted for
' local time zone bias.
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart
' Account for bug in IADslargeInteger property methods.
If lngLow < 0 Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0) Then
lngAdjust = 0
End If
lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) + lngLow) / 600000000 - lngAdjust) / 1440
Integer8Date = CDate(lngDate)
End Function
' Obtain local time zone bias from machine registry.
Function getLocaltimeZoneBias
Dim lngBiasKey, lngBias
lngBiasKey = WSHShell.RegRead("HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
If UCase(TypeName(lngBiasKey)) = "LONG" Then
lngBias = lngBiasKey
ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then
lngBias = 0
For k = 0 To UBound(lngBiasKey)
lngBias = lngBias + (lngBiasKey(k) * 256^k)
Next
End If
getLocaltimeZoneBias = lngBias
End Function 'getLocaltimeZoneBias
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
how can I write UTF-8 encoded strings to a textfile from VBScript? I have tried some variations but no success. So I need the text file saved in UTF-8 format. thanks in advance for your all help.
Output :
CN=™ser1 D˜,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;10.01.2012 01:00:00
CN=Gšbson ¦LU,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;20.12.2016 18:55:51
CN=™ZL €ET˜,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;27.08.2013
type ExpReport.txt (as you can see no special characters)
CN=ser1 D,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;10.01.2012 01:00:00
CN=Gbson LU,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;20.12.2016 18:55:51
CN=ZL ET,OU=TEST,OU=TEST,OU=Users,OU=contoso,DC=contoso,DC=local;27.08.2013
cscript //nologo AcctsExpire.vbs > ExpReport.txt
Here is my code :
Option Explicit
Dim adoConnection, adoCommand
Dim objRootDSE, strDNSDomain, strFilter, strQuery, adoRecordset
Dim strDN, objShell, lngBiasKey, lngBias
Dim lngDate, objDate, dtmAcctExp, k
' Obtain local time zone bias from machine registry.
Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
& "TimeZoneInformation\ActiveTimeBias")
If (UCase(TypeName(lngBiasKey)) = "LONG") Then
lngBias = lngBiasKey
ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
lngBias = 0
For k = 0 To UBound(lngBiasKey)
lngBias = lngBias + (lngBiasKey(k) * 256^k)
Next
End If
' Use ADO to search the domain for all users.
Set adoConnection = CreateObject("ADODB.Connection")
Set adoCommand = CreateObject("ADODB.Command")
adoConnection.Provider = "ADsDSOOBject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection
' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")
' Filter to retrieve all user objects with accounts
' that expire.
strFilter = "(&(objectCategory=person)(objectClass=user)" _
& "(!accountExpires=0)(!accountExpires=9223372036854775807))"
strQuery = "<LDAP://" & strDNSDomain & ">;" & strFilter _
& ";distinguishedName,accountExpires;subtree"
' Run the query.
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
Set adoRecordset = adoCommand.Execute
' Enumerate the recordset.
Do Until adoRecordset.EOF
strDN = adoRecordset.Fields("distinguishedName").Value
lngDate = adoRecordset.Fields("accountExpires")
Set objDate = lngDate
dtmAcctExp = Integer8Date(objDate, lngBias)
Wscript.Echo strDN & ";" & dtmAcctExp
adoRecordset.MoveNext
Loop
adoRecordset.Close
' Clean up.
adoConnection.Close
Function Integer8Date(ByVal objDate, ByVal lngBias)
' Function to convert Integer8 (64-bit) value to a date, adjusted for
' local time zone bias.
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objdate.LowPart
' Account for bug in IADslargeInteger property methods.
If (lngLow < 0) Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0) Then
lngAdjust = 0
End If
lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _
+ lngLow) / 600000000 - lngAdjust) / 1440
Integer8Date = CDate(lngDate)
End Function
Last Update :
Issue is resolved.
cscript //nologo AcctsExpire.vbs //U > ExpReport.txt
Also WSCRIPT AcctsExpire.vbs displays correct output.
I am trying to build on this previous post that works to convert a number to the specified base.
In my case I have a vbs script that is looking up a serial number and is outputting the alphanumeric character (base 36) to a txt file.
I would like to add to the txt file the base 10 value of the serial number. So I get an output like this:
Serial Number: ABC1234
Service Code: 22453156048
This is my starting point. This script runs and gives me a txt file with the Serial Number.
On Error Resume Next
' Initialize WSH objects
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Shell = WScript.CreateObject("WScript.Shell")
Set WNetwork = WScript.CreateObject("WScript.Network")
' Initialize WMI
Set WMI = GetObject("winmgmts:\\.\root\cimv2")
' Find client machine name
Set ComputerInfo = WMI.ExecQuery("Select * from Win32_ComputerSystem")
For Each temp In Computerinfo
WorkstationName = WNetwork.ComputerName
Next
Set Bios = WMI.ExecQuery("Select * from Win32_BIOS")
For Each temp In Bios
SerN = temp.SerialNumber
Next
' Create Logfiles
Dim sDateTimeStamp
sDateTimeStamp = cStr(Year(now())) & _
Pad(cStr(Month(now())),2) & _
Pad(cStr(Day(now())),2) & _
Pad(cStr(Hour(now())),2) & _
Pad(cStr(Minute(now())),2) & _
Pad(cStr(Second(now())),2)
Function Pad(CStr2Pad, ReqStrLen)
Dim Num2Pad
Pad = CStr2Pad
If Len(CStr2Pad) < ReqStrLen Then
Num2Pad = String((ReqStrlen - Len(CStr2Pad)), "0")
Pad = Num2Pad & CStr2Pad
End If
End Function
Set LogFile = FSO.CreateTextFile("c:\logs\" & WorkstationName & "_" & sDateTimeStamp & ".txt")
Set EnviromentVariables = Shell.Environment("PROCESS")
LogFile.Writeline("Serial Number:" & space(2) & SerN)
But when I try to add the script from the linked post I do not get any output file.
On Error Resume Next
' Initialize WSH objects
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Shell = WScript.CreateObject("WScript.Shell")
Set WNetwork = WScript.CreateObject("WScript.Network")
' Initialize WMI
Set WMI = GetObject("winmgmts:\\.\root\cimv2")
' Find client machine name
Set ComputerInfo = WMI.ExecQuery("Select * from Win32_ComputerSystem")
For Each temp In Computerinfo
WorkstationName = WNetwork.ComputerName
Next
Set Bios = WMI.ExecQuery("Select * from Win32_BIOS")
For Each temp In Bios
SerN = temp.SerialNumber
Function ToBase(ByVal n, b)
b = 10
n = SerN
If b < 2 Or b > 36 Then Exit Function
Const SYMBOLS = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Do
ToBase = Mid(SYMBOLS, n Mod b + 1, 1) & ToBase
n = Int(n / b)
Loop While n > 0
End Function
SrvCode = ToBase(SerN,10)
Next
' Create Logfiles
Dim sDateTimeStamp
sDateTimeStamp = cStr(Year(now())) & _
Pad(cStr(Month(now())),2) & _
Pad(cStr(Day(now())),2) & _
Pad(cStr(Hour(now())),2) & _
Pad(cStr(Minute(now())),2) & _
Pad(cStr(Second(now())),2)
Function Pad(CStr2Pad, ReqStrLen)
Dim Num2Pad
Pad = CStr2Pad
If Len(CStr2Pad) < ReqStrLen Then
Num2Pad = String((ReqStrlen - Len(CStr2Pad)), "0")
Pad = Num2Pad & CStr2Pad
End If
End Function
Set LogFile = FSO.CreateTextFile("c:\logs\" & WorkstationName & "_" & sDateTimeStamp & ".txt")
Set EnviromentVariables = Shell.Environment("PROCESS")
LogFile.Writeline("Serial Number:" & space(2) & SerN)
LogFile.Writeline("Service Code:" & space(3) & SrvCode)
Nested function definitions aren't allowed in VBScript. This should be raising a syntax error, despite the global On Error Resume Next (which you shouldn't be using in the first place).
Put the function definition somewhere in the global scope (outside the loop), e.g. by changing this:
Set Bios = WMI.ExecQuery("Select * from Win32_BIOS")
For Each temp In Bios
SerN = temp.SerialNumber
Function ToBase(ByVal n, b)
b = 10
n = SerN
If b < 2 Or b > 36 Then Exit Function
Const SYMBOLS = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Do
ToBase = Mid(SYMBOLS, n Mod b + 1, 1) & ToBase
n = Int(n / b)
Loop While n > 0
End Function
SrvCode = ToBase(SerN,10)
Next
into this:
Function ToBase(ByVal n, b)
If b < 2 Or b > 36 Then Exit Function
Const SYMBOLS = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Do
ToBase = Mid(SYMBOLS, n Mod b + 1, 1) & ToBase
n = Int(n / b)
Loop While n > 0
End Function
Set Bios = WMI.ExecQuery("Select * from Win32_BIOS")
For Each temp In Bios
SerN = temp.SerialNumber
SrvCode = ToBase(SerN,10)
Next
Make sure to remove the lines b = 10 and n = SerN. They're messing up the values passed to the parameters b and n.
Credit >> https://web.archive.org/web/20190717135154/http://www.4guysfromrolla.com:80/webtech/032400-1.shtml
I was unable to get the calculation to run using the ToBase Function. But with some more googling I found the above link and I was able to use the referenced function to get the desired output. This now allows me add to a existing script to get the express service code when doing a remote lookup of a Dell computers Service Tag.
So here is the final working script that gives the expected output.
' Initialize WSH objects
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Shell = WScript.CreateObject("WScript.Shell")
Set WNetwork = WScript.CreateObject("WScript.Network")
' Initialize WMI
Set WMI = GetObject("winmgmts:\\.\root\cimv2")
' Find client machine name
Set ComputerInfo = WMI.ExecQuery("Select * from Win32_ComputerSystem")
For Each temp In Computerinfo
WorkstationName = WNetwork.ComputerName
Next
Function baseN2dec(value, inBase)
'Converts any base to base 10
Dim strValue, i, x, y
strValue = StrReverse(CStr(UCase(value)))
For i = 0 To Len(strValue)-1
x = Mid(strValue, i+1, 1)
If Not isNumeric(x) Then
y = y + ((Asc(x) - 65) + 10) * (inBase ^ i)
Else
y = y + ((inBase ^ i) * CInt(x))
End If
Next
baseN2dec = y
End Function
Set Bios = WMI.ExecQuery("Select * from Win32_BIOS")
For Each temp In Bios
SerN = temp.SerialNumber
SrvCd = baseN2dec(SerN, 36)
Next
' Create Logfiles
Dim sDateTimeStamp
sDateTimeStamp = cStr(Year(now())) & _
Pad(cStr(Month(now())),2) & _
Pad(cStr(Day(now())),2) & _
Pad(cStr(Hour(now())),2) & _
Pad(cStr(Minute(now())),2) & _
Pad(cStr(Second(now())),2)
Function Pad(CStr2Pad, ReqStrLen)
Dim Num2Pad
Pad = CStr2Pad
If Len(CStr2Pad) < ReqStrLen Then
Num2Pad = String((ReqStrlen - Len(CStr2Pad)), "0")
Pad = Num2Pad & CStr2Pad
End If
End Function
Set LogFile = FSO.CreateTextFile("c:\logs\" & WorkstationName & "_" & sDateTimeStamp & ".txt")
Set EnviromentVariables = Shell.Environment("PROCESS")
LogFile.Writeline("Serial Number:" & space(2) & SerN)
LogFile.Writeline("Service Code:" & space(3) & SrvCd)
In VBScript, I would like to update a text file with new data and have it shown in a message box.
Below is what I have so far; what am I doing wrong?
Option Explicit
Dim oFso, Michael, John, Valery, Susane, Katterina
Dim oStream, oFolder, f, myArrayList
Const ForAppending = 8
Const ForReading = 1, ForWriting = 2
Set myArrayList = CreateObject("System.Collections.ArrayList")
myArrayList.Add "Misko, Janko, Vierka,"
'create '
Call WriteLineToFile
Function WriteLineToFile
Set oFso = CreateObject("Scripting.FileSystemObject")
Set f = oFso.CreateTextFile("D:\TestFile1.txt", 2, True)
f.WriteLine "Misko, Janko, Vierka,"
MsgBox "Subor C:\TestFile.txt bol " & "vytvoreny."
f.Close
Set f = Nothing
Set oFso = Nothing
MsgBox "Uspesne vytvoreny " & TestFile2.txt & "."
End Function
Option Explicit 'explicit declaration of all variables'
Dim oFso, f, sPath, sPath2, i, sTemp 'deklaracia'
Dim arrString
Const ForReading = 1, ForWriting = 2
sPath = "D:\TestFile1.txt" 'cesta ku datam'
sPath2 = "D:\TestFile2.txt"
arrString = Array("Marek", "Tomas") 'pole alebo polia'
ReDim arrString(2)
arrString(0) = "Misko"
arrString(1) = "Janko"
arrString(2) = "Vierka"
sTemp = "" 'empty pole pred runom'
For i = 0 To UBound(arrString) 'ide po upper bound '
If i = UBound(arrString) Then
sTemp = sTemp + arrString(i) 'odstrani ciarku na konci'
Else
sTemp = sTemp + arrString(i) + ", "
End If
Next
MsgBox sTemp
Call WriteLineToFile (sPath, sTemp) 'zavola sub routine'
ReDim Preserve arrString (4)
arrString(3) = "Zuzka"
arrString(4) = "Katka"
sTemp = ""
For i = 0 To UBound(arrString)
If i = UBound(arrString) Then
sTemp = sTemp + arrString(i)
Else
sTemp = sTemp + arrString(i) + ", "
End If
Next
MsgBox sTemp
Call WriteLineToFile (sPath2, sTemp)
Sub WriteLineToFile (sFilePath, sText)
Set oFso = CreateObject("Scripting.FileSystemObject")
Set f = oFso.CreateTextFile(sFilePath, 2, True)
'For i = 0 To UBound(arrString) - 1 'nepotrebne'
f.WriteLine sText
'Next
MsgBox "Subor " & sFilePath & " vytvoreny."
f.Close
Set f = Nothing
Set oFso = Nothing
End Sub
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