I'm having trouble with my code, i tried to google it but im failed fixing it. I hope someone can help me how to figure out what's wrong with my code. TIA
here is the Proc_9_6_4163C4
Public Sub Proc_9_6_4163C4(arg_C, arg_10, arg_14) '4163C4
'Data Table: 40170C
Dim var_120 As Variant
loc_4161D8: On Error GoTo loc_4163C2
loc_4161E1: var_98 = CVar(arg_C) 'Variant
loc_4161EB: var_A8 = CVar(arg_10) 'Variant
loc_4161F5: var_C8 = CVar(arg_14) 'Variant
loc_41620A: ReDim var_CC(0 To CLng(Len(var_A8)))
loc_416225: ReDim var_D0(0 To CLng(Len(var_C8)))
loc_41623E: For var_150 = 1 To Len(var_A8): var_E0 = var_150 'Variant
loc_41626F: var_CC(CLng(var_E0)) = CByte(Asc(CStr(Mid(var_A8, CLng(var_E0), 1))))
loc_41627E: Next var_150 'Variant
loc_416293: For var_184 = 1 To Len(var_C8): var_E0 = var_184 'Variant
loc_4162C4: var_D0(CLng(var_E0)) = CByte(Asc(CStr(Mid(var_C8, CLng(var_E0), 1))))
loc_4162D3: Next var_184 'Variant
loc_4162DE: var_F0 = 1 'Variant
loc_4162E7: var_100 = 1 'Variant
loc_4162FA: For var_1A4 = 1 To Len(var_98): var_E0 = var_1A4 'Variant
loc_416350: var_B8 = var_B8 & Chr(CLng(Asc(CStr(Mid(var_98, CLng(var_E0), 1))) Xor CInt(var_CC(CLng(var_F0))) Xor CInt(var_D0(CLng(var_100))))) 'Variant
loc_41636C: If (var_F0 = Len(var_A8)) Then
loc_416374: var_F0 = 0 'Variant
loc_416378: End If
loc_416384: If (var_100 = Len(var_C8)) Then
loc_41638C: var_100 = 0 'Variant
loc_416390: End If
loc_416398: var_120 = (var_F0 + 1)
loc_41639C: var_F0 = Len(var_C8) 'Variant
loc_4163A8: var_120 = (var_100 + 1)
loc_4163AC: var_100 = Len(var_C8) 'Variant
loc_4163B3: Next var_1A4 'Variant
loc_4163BE: var_88 = CStr(var_B8)
loc_4163C2: Exit Sub
End Sub
and here is my code on my button click
Private Sub Command1_Click()
Dim var_C0 As Variant
Dim var_FC As Variant
Dim var_13C As String
Dim var_10C As String
var_88 = Replace("B5BD-BEBA-BBB9-B8B8-BD", "-", vbNullString, 1, -1, 0)
var_88 = Proc_9_6_4163C4(var_88, CStr(Chr(&HFF) & Chr(&HFE) & Chr(&HFD)))
For var_EC = 1 To CInt(Len(var_88)): var_E2 = var_EC 'Integer
If ((var_E2 Mod 4) = 0) Then
var_13C = "-"
var_E8 = CStr(CVar(var_E8) & Hex(CVar(Asc(CStr(Mid(var_88, CLng(var_E2), 1))))) & var_13C)
Else
var_E8 = CStr(CVar(var_E8) & Hex(CVar(Asc(CStr(Mid(var_88, CLng(var_E2), 1))))))
End If
Next var_EC 'Integer
var_D0 = (Right(var_FC, 1) = var_10C) 'Variant
Text1.Text = (CStr(IIf(var_D0, CVar(Asc(CStr(Mid(var_88, CLng(var_E2), 1)))), var_E8)))
End Sub
i'm having trouble with this line. : var_88 = Proc_9_6_4163C4(var_88, CStr(Chr(&HFF) & Chr(&HFE) & Chr(&HFD)))
i tried add some set on var_88 = Proc_9_6_4163C4(var_88, CStr(Chr(&HFF) & Chr(&HFE) & Chr(&HFD)))
i put like this set var_88 = Proc_9_6_4163C4(var_88, CStr(Chr(&HFF) & Chr(&HFE) & Chr(&HFD)))
but still i didn't get nothing.
To call the procedure 3 arguments need to be passed while the call
var_88 = Proc_9_6_4163C4(var_88, CStr(Chr(&HFF) & Chr(&HFE) & Chr(&HFD)))
has only 2 arguments. Pass 1 more argument to the call.
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 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 want to create a webcam application that can save image to database. My code is from the internet. My code can only save binary but I guess my conversion was incorrect because I can't retrieve them from the database.
Here is my Code:
Private Sub cmdsave_Click()
OpenDB
rs.Open "tblimg", db, adOpenKeyset, adLockPessimistic, adCmdTable
Dim bytData() As Byte, PicInfo As BITMAP
If Dir(App.path & "\myPic", vbDirectory) = "" Then MkDir (App.path & "\myPic")
File1.path = App.path & "\myPic"
'File1.Pattern = "*.bmp"
File1.Pattern = "*.jpg"
File1.Refresh
Dim Maxnum As Integer, ii As Integer
For ii = 0 To File1.ListCount - 1
If Left(File1.List(ii), 1) = "p" Then
If CInt(Mid(File1.List(ii), 2, Len(File1.List(ii)) - 4)) > Maxnum Then
Maxnum = CInt(Mid(File1.List(ii), 2, Len(File1.List(ii)) - 4))
End If
End If
Next
Picture1.Picture = Image1.Picture
'SavePicture Image1.Picture, App.Path & "\myPic\p" & Maxnum + 1 & ".bmp"
SAVEJPEG App.path & "\myPic\p" & Maxnum + 1 & ".jpg", 100, Me.Picture1
ReDim bytData((PicInfo.bmHeight * PicInfo.bmWidth)) As Byte
With rs
.AddNew
.Fields("Picture").AppendChunk bytData
.Fields("Desc") = Label2.Caption
.Update
End With
Set rs = Nothing
db.Close: Set db = Nothing
End Sub
Hope this code give you idea of what you want to achive
Picture3.Visible = True
SavePicture Picture1.Picture, App.Path & "\Emp Photo\" & UCase(Trim(G_EmpCode)) _ & ".jpg"
Picture3.Picture = LoadPicture(App.Path & "\Emp Photo\" & UCase(Trim(G_EmpCode)) & ".jpg")
Picture2.Picture = LoadPicture(App.Path & "\Emp Photo\" & UCase(Trim(G_EmpCode)) & ".jpg")
FrmEmployee.Image1.Picture = Picture2.Picture
CCTVImagePath = App.Path & "\Emp Photo\" & UCase(Trim(G_EmpCode)) & ".jpg"
Call cmdClose_Click
Call CmdStart_Click
If CCTVImagePath <> "" Then
ImagePath = CCTVImagePath
m_imgfile = CCTVImagePath
End If
If FileSystemObj.FileExists(ImagePath) = True Then
Set strStream = New ADODB.Stream
strStream.Type = adTypeBinary
strStream.Open
Sourcefile = ImagePath
strStream.LoadFromFile Sourcefile
CCTVImagePath = ""
End If
CCTVImagePath = ""
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
This script works and tells and me what is installed in Program files.
Two problems
Duplicate lines
i.e
AVG 2011 Ver: 10.0.1204
AVG 2011 Ver: 10.0.1204 Installed: 27/01/2011
and
I don't want to include lines that have key words "Update","Hotfix","Java" can any VB gurus out there help with what extra is needed in this script?
Option Explicit
Dim sTitle
sTitle = "Installed Programs on your PC -"
Dim StrComputer
strComputer = Trim(strComputer)
If strComputer = "" Then strComputer = "."
'Wscript.Echo GetAddRemove(strComputer)
Dim sCompName : sCompName = GetProbedID(StrComputer)
Dim sFileName
sFileName = sCompName & "_" & GetDTFileName() & "_Software.txt"
Dim s : s = GetAddRemove(strComputer)
If WriteFile(s, sFileName) Then
'optional prompt for display
If MsgBox("Finished processing. Results saved to " & sFileName & _
vbcrlf & vbcrlf & "Do you want to view the results now?", _
4 + 32, sTitle) = 6 Then
WScript.CreateObject("WScript.Shell").Run sFileName, 9
End If
End If
Function GetAddRemove(sComp)
'Function credit to Torgeir Bakken
Dim cnt, oReg, sBaseKey, iRC, aSubKeys
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
sComp & "/root/default:StdRegProv")
sBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
iRC = oReg.EnumKey(HKLM, sBaseKey, aSubKeys)
Dim sKey, sValue, sTmp, sVersion, sDateValue, sYr, sMth, sDay
For Each sKey In aSubKeys
iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, "DisplayName", sValue)
If iRC <> 0 Then
oReg.GetStringValue HKLM, sBaseKey & sKey, "QuietDisplayName", sValue
End If
If sValue <> "" Then
iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
"DisplayVersion", sVersion)
If sVersion <> "" Then
sValue = sValue & vbTab & "Ver: " & sVersion
Else
sValue = sValue & vbTab
End If
iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
"InstallDate", sDateValue)
If sDateValue <> "" Then
sYr = Left(sDateValue, 4)
sMth = Mid(sDateValue, 5, 2)
sDay = Right(sDateValue, 2)
'some Registry entries have improper date format
On Error Resume Next
sDateValue = DateSerial(sYr, sMth, sDay)
On Error GoTo 0
If sdateValue <> "" Then
sValue = sValue & vbTab & "Installed: " & sDateValue
End If
End If
sTmp = sTmp & sValue & vbcrlf
cnt = cnt + 1
End If
Next
sTmp = BubbleSort(sTmp)
GetAddRemove = "INSTALLED SOFTWARE (" & cnt & ") - " & sCompName & _
" - " & Now() & vbcrlf & vbcrlf & sTmp
End Function
Function BubbleSort(sTmp)
'cheapo bubble sort
Dim aTmp, i, j, temp
aTmp = Split(sTmp, vbcrlf)
For i = UBound(aTmp) - 1 To 0 Step -1
For j = 0 to i - 1
If LCase(aTmp(j)) > LCase(aTmp(j+1)) Then
temp = aTmp(j + 1)
aTmp(j + 1) = aTmp(j)
aTmp(j) = temp
End if
Next
Next
BubbleSort = Join(aTmp, vbcrlf)
End Function
Function GetProbedID(sComp)
Dim objWMIService, colItems, objItem
Set objWMIService = GetObject("winmgmts:\\" & sComp & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select SystemName from " & _
"Win32_NetworkAdapter",,48)
For Each objItem in colItems
GetProbedID = objItem.SystemName
Next
End Function
Function GetDTFileName()
dim sNow, sMth, sDay, sYr, sHr, sMin, sSec
sNow = Now
sMth = Right("0" & Month(sNow), 2)
sDay = Right("0" & Day(sNow), 2)
sYr = Right("00" & Year(sNow), 4)
sHr = Right("0" & Hour(sNow), 2)
sMin = Right("0" & Minute(sNow), 2)
sSec = Right("0" & Second(sNow), 2)
GetDTFileName = sMth & sDay & sYr & "_" & sHr & sMin & sSec
End Function
Function WriteFile(sData, sFileName)
Dim fso, OutFile, bWrite
bWrite = True
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set OutFile = fso.OpenTextFile(sFileName, 2, True)
'Possibly need a prompt to close the file and one recursion attempt.
If Err = 70 Then
Wscript.Echo "Could not write to file " & sFileName & ", results " & _
"not saved." & vbcrlf & vbcrlf & "This is probably " & _
"because the file is already open."
bWrite = False
ElseIf Err Then
WScript.Echo err & vbcrlf & err.description
bWrite = False
End If
On Error GoTo 0
If bWrite Then
OutFile.WriteLine(sData)
OutFile.Close
End If
Set fso = Nothing
Set OutFile = Nothing
WriteFile = bWrite
End Function
#icecurtain: The second part of your question can be solved using InStr as suggested by #Oliver, rewritten to suit your script it would look like --
If sValue <> "" _
AND (InStr(1, sValue, "Hotfix", 1)) = 0 _
AND (InStr(1, sValue, "Update", 1)) = 0 _
AND (InStr(1, sValue, "Java", 1)) = 0) Then
The first part wouldn't be that tricky either except for the fact that you include a version and installation date if found (which some of the duplicates will only include in part or not at all). If the extra bits of data wasn't included, you could loop through all the lines and add them into a Scripting.Dictory object with a .Exists check to prevent a duplicate from being added.
Ok, even if i'm not a jedi master (or have no self-respect ;-)), this could help you:
If InStr(1, sValue, "hotfix", vbTextCompare) = 0 Then
Print "This is NOT a hotfix"
End If
For further informations just take a look at the MSDN page for InStr().
I don't think hardcoded string checks are the way to go, a uninstall entry is a update if any of these are true:
It has a dword value named SystemComponent that is <> 0
A string value named ParentKeyName
The registry sub key starts with "KB" or "Q" + 6 numbers (KB######,Q######)