Using VBS to Backup a file - vbscript

I managed to find this script to use and backup my files, this is a little more complicated then I need it to be.
I do not need to enter a backup path - from and too every time I run it however this is a handy option for other projects but I would like to backup from a set file path and save to a set file path to save time.
The other issue with this script is the Cancel button does not work, this is an issue I have had before and fixed but I cannot remember how to make the Cancel button function.
Option Explicit
Dim objFSO, strSourceFolder, strDestFolder, strExclusion, strPrompt
Set objFSO = CreateObject("Scripting.FileSystemObject")
strSourceFolder = InputBox("Enter the Source directory path you wish to backup")
strDestFolder = InputBox("Enter the Destination directory path you wish to backup your Data to... (C:/Backup, //Backup-Server/Remotebackup")
Wscript.Echo "Click (OK) to start the Backup!"
CopyFolderStructure strSourceFolder, strDestFolder, strExclusion
Function CopyFolderStructure(strSource, strDestination, strExcludedExt)
Const OVER_WRITE_FILES = True
Dim objDir, objFolder, objFiles, strCurExt, intX, arrExt, blnExclude
Set objDir = objFSO.GetFolder(strSource)
If Not objFSO.FolderExists(strDestination & "\" & objDir.Name) Then
objFSO.CreateFolder(strDestination & "\" & objDir.Name)
End If
If Not IsNoData(strExcludedExt) Then
arrExt = Split(strExcludedExt, ",")
blnExclude = False
End If
For Each objFiles In objFSO.GetFolder(strSource).Files
If Not IsNoData(strExcludedExt) Then
strCurExt = objFSO.GetExtensionName(objFiles.Name)
For intX = 0 To UBound(arrExt)
If LCase(strCurExt) = arrExt(intX) Then
blnExclude = True
Exit For
Else
blnExclude = False
End If
Next
If Not blnExclude Then
objFSO.CopyFile strSource & "\" & objFiles.Name, strDestination & "\" & objDir.Name & "\" & objFiles.Name, OVER_WRITE_FILES
End If
Else
objFSO.CopyFile strSource & "\" & objFiles.Name, strDestination & "\" & objDir.Name & "\" & objFiles.Name, OVER_WRITE_FILES
End If
Next
For Each objFolder In objFSO.GetFolder(strSource).SubFolders
CopyFolderStructure objFolder.Path, strDestination & "\" & objDir.Name, strExcludedExt
Next
End Function
Function BrowseForFolderDialogBox(strTitle)
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = &H0001
Dim objShellApp
Dim objFolder
Dim objFldrItem
Dim objPath
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.BrowseForFolder(WINDOW_HANDLE, strTitle , NO_OPTIONS)
If IsNoData(objFolder) Then
WScript.Echo "You choose to cancel. This will stop this script."
Wscript.Quit
Else
Set objFldrItem = objFolder.Self
objPath = objFldrItem.Path
BrowseForFolderDialogBox = objPath
Set objShellApp = Nothing
Set objFolder = Nothing
Set objFldrItem = Nothing
End If
End Function
Function IsNoData(varVal2Check)
On Error Resume Next
If IsNull(varVal2Check) Or IsEmpty(varVal2Check) Then
IsNoData = True
Else
If IsDate(varVal2Check) Then
IsNoData = False
Elseif varVal2Check = "" Then
IsNoData = True
ElseIf Not IsObject(varVal2Check) Then
IsNoData = False
Else
IsNoData = False
End If
End If
End Function
Wscript.Echo "Backup Has Completed Successfully"

Next code snippet could help (see Arguments Property (WScript Object), InputBox Function and MsgBox Function reference). Note that the Echo method behaves differently depending on which WSH engine you are using.
Option Explicit
Dim objFSO, strSourceFolder, strDestFolder, strExclusion, strPrompt
Dim iBut, sRes, sMes, objArgs
sRes = Wscript.ScriptName
sMes = vbCRLF & "(click (Cancel) button to discard)"
Set objArgs = WScript.Arguments
If objArgs.Count > 1 Then
strSourceFolder = objArgs( 0)
strDestFolder = objArgs( 1)
Else
strSourceFolder = "C:/DataToBackup"
strDestFolder = "D:/Backup"
strSourceFolder = InputBox( "Path you wish to backup" & sMes _
, "Source directory", strSourceFolder)
sRes = sRes & vbNewLine & "strSourceFolder """ & strSourceFolder & """"
If strSourceFolder = "" Then
strDestFolder = ""
Else
strDestFolder = InputBox( "Path you wish to backup your Data to" & sMes _
, "Destination directory", strDestFolder)
sRes = sRes & vbNewLine & "strDestFolder """ & strDestFolder & """"
End If
End If
If strDestFolder = "" Then
sRes = sRes & vbNewLine & "Backup Cancelled!"
Wscript.Echo sRes
Wscript.Quit
Else
iBut=MsgBox(sRes & sMes, vbOKCancel + vbQuestion _
, "Click (OK) to start the Backup!")
If iBut <> vbOK Then Wscript.Quit
End If
'''' for debugging only:
Wscript.Quit '''' for debugging only:
'''' for debugging only:
Set objFSO = CreateObject("Scripting.FileSystemObject")
CopyFolderStructure strSourceFolder, strDestFolder, strExclusion
'''''' and so on...

Related

Vbscript Website Content, SelectAll Copy and Past into a Notepad *Help*

I got the code to copy the contents of a website into notepad:
With CreateObject("InternetExplorer.Application")
.Visible = False
.Navigate "https://example.com"
Do Until .ReadyState = 4
Wscript.Sleep 100
Loop
For Each Tag In .Document.GetElementsByTagName("script")
Tag.OuterHtml = ""
Next
For Each Tag In .Document.GetElementsByTagName("noscript")
Tag.OuterHtml = ""
Next
Content = .Document.GetElementsByTagName("body")(0).InnerText
Do While InStr(Content, vbCrLf & vbCrLf)
Content = Replace(Content, vbCrLf & vbCrLf, vbCrLf)
Loop
ShowInNotepad Content
.Quit
End With
Sub ShowInNotepad(Content)
With CreateObject("Scripting.FileSystemObject")
TempPath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%TEMP%") & "\" & .GetTempName
With .CreateTextFile(TempPath, True, True)
.WriteLine (Content)
.Close
End With
CreateObject("WScript.Shell").Run "notepad.exe " & TempPath, 1, True
.DeleteFile (TempPath)
End With
End Sub
I am stuck with above script to save the text as file.txt.
Please help.
Try something like that :
Option Explicit
Dim LogFile,Ws,Tag,Content
LogFile = Left(Wscript.ScriptFullName,InstrRev(Wscript.ScriptFullName, ".")) & "txt"
Set Ws = CreateObject("wscript.Shell")
With CreateObject("InternetExplorer.Application")
.Visible = False
.Navigate "https://example.com"
Do Until .ReadyState = 4
Wscript.Sleep 100
Loop
For Each Tag In .Document.GetElementsByTagName("script")
Tag.OuterHtml = ""
Next
For Each Tag In .Document.GetElementsByTagName("noscript")
Tag.OuterHtml = ""
Next
Content = .Document.GetElementsByTagName("body")(0).InnerText
Do While InStr(Content, vbCrLf & vbCrLf)
Content = Replace(Content, vbCrLf & vbCrLf, vbCrLf)
Loop
WriteLog Content,LogFile
.Quit
End With
Ws.Run LogFile
'*******************************************************************
Sub WriteLog(strText,LogFile)
Dim fso,ts
Const ForWriting = 2
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(LogFile,ForWriting,True,-1)
ts.WriteLine strText
ts.Close
End Sub
'******************************************************************

Sync outlook messages with vbscript

I have a vbscript that copy's Outlook 2003 messages into a folder in msg format.
The problems are:
I am getting "path too long" errors for some *.msg . I wish to avoid these erros and I don't know how. ' On Error Resume Next is already on the script.
I am getting only inbox messages, but I want all subfolders too;
How can I extract this in *.txt and not in *.msg, in order to become lighter?
Here is my atual script. Thanks for the help!
On Error Resume Next
Dim myNameSpace
Dim ofChosenFolder
Dim myOlApp
Dim myItem
Dim objItem
Dim myFolder
Dim strSubject
Dim strName
Dim strFile
Dim strReceived
Dim strSavePath
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Const olFolderInbox = 6
Set ofChosenFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
strSavePath = "c:\test\" 'OBS! use a \ at the end of the path
i = 1
For each Item in ofChosenFolder.Items
Set myItem = ofChosenFolder.Items(i)
strReceived = ArrangedDate(myitem.ReceivedTime)
' strSubject = myItem.Subject
strSubject = myitem.SenderName & "_" & myitem.Subject
strName = StripIllegalChar(strSubject)
strFile = strSavePath & strReceived & "_" & strName & ".msg"
If Not Len(strfile) > 256 then
myItem.SaveAs strfile, 3
Else
wscript.echo strfile & vbcrlf & "Path and filename too long."
End If
i = i + 1
next
Function StripIllegalChar(strInput)
'***************************************************
'Simple function that removes illegal file system
'characters.
'***************************************************
Set RegX = New RegExp
RegX.pattern = "[\" & chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(strInput, "")
Set RegX = nothing
End Function
Function ArrangedDate(strDateInput)
'***************************************************
'This function re-arranges the date data in order
'for it to display in chronilogical order in a
'sorted list in the file system. It also removes
'illegal file system characters and replaces them
'with dashes.
'Example:
'Input: 2/26/2004 7:07:33 AM
'Output: 2004-02-26_AM-07-07-33
'***************************************************
Dim strFullDate
Dim strFullTime
Dim strAMPM
Dim strTime
Dim strYear
Dim strMonthDay
Dim strMonth
Dim strDay
Dim strDate
Dim strDateTime
Dim RegX
If not Left(strDateInput, 2) = "10" Then
If not Left(strDateInput, 2) = "11" Then
If not Left(strDateInput, 2) = "12" Then
strDateInput = "0" & strDateInput
End If
End If
End If
strFullDate = Left(strDateInput, 10)
If Right(strFullDate, 1) = " " Then
strFullDate = Left(strDateInput, 9)
End If
strFullTime = Replace(strDateInput,strFullDate & " ","")
If Len(strFullTime) = 10 Then
strFullTime = "0" & strFullTime
End If
strAMPM = Right(strFullTime, 2)
strTime = strAMPM & "-" & Left(strFullTime, 8)
strYear = Right(strFullDate,4)
strMonthDay = Replace(strFullDate,"/" & strYear,"")
strMonth = Left(strMonthDay, 2)
strDay = Right(strMonthDay,len(strMonthDay)-3)
If len(strDay) = 1 Then
strDay = "0" & strDay
End If
strDate = strYear & "-" & strMonth & "-" & strDay
'strDateTime = strDate & "_" & strTime
strDateTime = strDate
Set RegX = New RegExp
RegX.pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(strDateTime, "-")
Set RegX = nothing
End Function
You need to truncate the file name appropriately (strName)
Move your code that processes a folder into a sub that take fodler that takes folder as parameter and call it for ofChosenFolder as well as all of its child fodlers in the ofChosenFolder.Folders collection.
You are calling SaveAs..., 3 - 3 here is olMsg. Specify olTxt (= 0).
Off the top of my head:
Const olFolderInbox = 6
Set ofChosenFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
trSavePath = "c:\test\"
ProcessFolder ofChosenFolder, trSavePath
sub ProcessFolder(folder, path)
For each Item in folder.Items
strReceived = ArrangedDate(Item.ReceivedTime)
strSubject = Item.SenderName & "_" &Item .Subject
strName = StripIllegalChar(strSubject)
strFile = strSavePath & strReceived & "_" & strName & ".msg"
If Not Len(strfile) > 256 then
Item.SaveAs strfile, 3
Else
wscript.echo strfile & vbcrlf & "Path and filename too long."
End If
next
for each subfolder in folder.Folders
ProcessFolder(subfolder, trSavePath & subfolder.Name & "\"
next
end sub

VB script to scan latest log file for errors

I have a VB script which scans the mentioned log file for errors and sends a notification through an email.
How can I scan the latest log file in the folder? For example, Filename1.070615 (Filename1.mmddyy) is a log file. After a certain size, the logfile switches to new file with the same name but different date: Filename1.070615.
cdoSendUsingPort = 2, _
Const ForReading = 1
Dim intStartAtLine, strFileCreateddate, i, strResults, strTextToScanFor, bStartFromScratch
Dim strLastCheckedFor, strArrayToString, strSubject, strMailFrom, strMailTo
strMailto = "<Emailaddress>"
strMailFrom = "<FromAddress>"
strSubject = "Log scanner"
strSMTPServer = "x.x.x.x"
FileToRead = "D:\LOG\filename1.mmddyy"
arrTextToScanFor = Array("error","another thing")
Set WshShell = WScript.CreateObject("WScript.Shell")
searchkey = replace(replace(filetoread,":",""),"\","_")
On Error Resume Next
strLastFileCheckedCreateDate = WshShell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CreateDate")
strLastFileLastLineChecked = WshShell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked")
strLastCheckedFor = WshSHell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CheckForString")
iLastCheckedLine = WshSHell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked")
On Error GoTo 0
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set varFile = objFSO.GetFile(FileToRead)
arrLastCheckedForText = split(strLastCheckedFor,",")
strFileCreateDate = varfile.datecreated
strFileModifiedDate = varfile.datelastmodified
sStatus = "<li>Using mail server: " & strSMTPServer & "</li><li>Running from: " & wscript.scriptfullname & "</li>"
Set objTextFile = objFSO.OpenTextFile(FileToRead, ForReading)
objTextFile.ReadAll
iLineCount = objTextFile.Line
objTextFile.close
If strLastCheckedFor = "" Then
bStartFromScratch = true
sStatus = sStatus & "<li>First run of script against string search</li>" & vbcrlf
ElseIf ubound(arrTextToScanFor) <> ubound(arrLastCheckedForText) Then
bStartFromScratch = true
sStatus = sStatus & "<li>Count of string search criteria has changed</li>" & vbcrlf
Else
For each strItem in arrTextToScanFor
Else
bStartFromScratch = true
'MsgBox strResults
End If
If bStartFromScratch = true Then
sStatus = sStatus & "<li>String search criteria does not match prior search</li>" & vbcrlf
End If
Next
End If
If cint(iLineCount) < cint(iLastCheckedLine) Then
bStartFromScratch = true
sStatus = sStatus & "<li>Last line checked (" & iLastCheckedLine & ") is greater than total line count (" & iLineCount & ") in file</li>"
End If
If CStr(strFileCreateDate) = CStr(strLastFileCheckedCreateDate) and bStartFromScratch <> true Then
intStartAtLine = strLastFileLastLineChecked
If bStartFromScratch <> true then
sStatus = sStatus & "<li>Continuing search from line " & intStartAtLine & "</li>" & vbcrlf
End If
ElseIf strFileCreateDate <> strLastFileCheckedCreateDate or bStartFromScratch = true Then
intStartAtLine = 0
If bStartFromScratch <> true then
sStatus = sStatus & "<li>File created date has changed, starting search from line 0</li>" & vbcrlf
End If
End If
i = 0
Dim strNextLine
For each strItem in arrTextToScanFor
strArrayToString = strArrayToString & delim & strItem
delim = ","
Next
Set objTextFile = objFSO.OpenTextFile(FileToRead, ForReading)
Do While objTextFile.AtEndOfStream <> True
If i < CInt(intStartAtLine) Then
objTextFile.skipline
Else
'MsgBox i
strNextLine = objTextFile.Readline
For each strItem in arrTextToScanFor
If InStr(LCase(strNextLine),LCase(strItem)) Then
strResults = "<span style='font-family:courier-new;color:#696969'><span style='font-weight:bold;background-color:#BEF3F3'>Line " & i & ":</span> " & replace(lcase(strNextLine),lcase(strItem),"<span style='background-color:#FFFF81'>" & strItem & "</span>") & "</span><br>" & vbcrlf & strResults
bSendMail = true
End If
Next
End If
i = i + 1
Loop
objTextFile.close
Set WshShell = CreateObject("WScript.Shell")
'Let's save our settings for next time.
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\FileChecked", FileToRead, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CreateDate", strFileCreateDate, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked", i, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastScanned", Now, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CheckForString",strArrayToString, "REG_SZ"
set WshShell = nothing
strFileSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>File path:</td><td>" & FileToRead & "</td></tr>"
strFileCreateDateSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Created date:</td><td>" & strFileCreateDate & "</td></tr>"
strFileModifiedDateSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Modified date:</td><td>" & strFileModifiedDate & "</td></tr>"
strArraySummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Text string(s):</td><td>" & strArrayToString & "</td></tr>"
strFileLineSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Last line checked:</td><td>" & i & "</td></tr>"
strSummary = strFileSummary & strFileCreateDateSummary & strFileModifiedDateSummary & strArraySummary & strFileLineSummary
strBodyContent = "<table style='font-family:calibri;'>" & strSummary & "</table><br><br><span style='font-size:large;'>Entries:</span><br>" & strResults & "<div style='padding-top:30px;font-size:x-small'><br><div style='font-weight:bold;font-family:calibri;color:black;'>Job Details:<ul style='font-weight:normal;font-family:calibri;color:darkgray;'>" & sStatus & "</ul></div></div>"
on error goto 0
'Send the email if need be.
If bSendMail = true Then Call sendmail(strMailFrom,strMailTo,strSubject,strBodyContent)
'------------------------------------------------------------------------
'Function EmailFile - email the warning file
'------------------------------------------------------------------------
Function SendMail(strFrom,strTo,strSubject,strMessage)
Dim iMsg, iConf, Flds
On Error GoTo 0
'// Create the CDO connections.
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
'// SMTP server configuration.
With Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort
'// Set the SMTP server address here.
.Item(cdoSMTPServer) = strSMTPServer
.Update
End With
'// Set the message properties.
With iMsg
Set .Configuration = iConf
.To = strMailTo
.From = strMailFrom
.Subject = strSubject
.htmlbody = strMessage
End With
'iMsg.HTMLBody = strMessage
'// Send the message.
iMsg.Send ' send the message.
If CStr(err.number) <> 0 Then
Else
End If
End Function
It would be a bit easier if your log files were named filename1.yymmdd.
Nevertheless, we can use a regex to not only verify the filename but also swap the date components to put them in our desired format!
Set re = New RegExp
re.Pattern = "^(filename1\.)(\d{2})(\d{2})(\d{2})$"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each objFile In fso.GetFolder("d:\log").Files
If re.Test(objFile.Name) Then
strCompareName = re.Replace(objFile.Name, "$1$4$2$3")
If strCompareName > strLatest Then strLatest = strCompareName
End If
Next
' Switch the name back...
strLatest = re.Replace(strLatest, "$1$3$4$2")
WScript.Echo "The latest file is: " & strLatest
This line:
strCompareName = re.Replace(objFile.Name, "$1$4$2$3")
changes the format from mmddyy to yymmdd and saves it in a string for comparison.
Once we've finished our comparisons, we just need to take the latest file we found and reverse the process:
strLatest = re.Replace(strLatest, "$1$3$4$2")
to get the original filename back!

what is the best way to get the pst file sizes

Could someone please suggest the best way to grab the pst file sizes and write them out to the same text file next to the pst path.
Could someone please suggest the best way to grab the pst file sizes and write them out to the same text file next to the pst path.
Dim objNetworkSet, objFSO, objFolder, objShell, objTextFile, objFile, objWMISysEnv,ObjItem, objTextFileUNC
Dim strHomePath, strDirectory, strFile, strText, strComputerName,strDirectoryUNC,strFileUNC
dim colItems
On Error Resume Next
Set objNetwork = CreateObject("WScript.Network")
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
objNS.Logon "Mike", "" , False, True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wshShell = WScript.CreateObject("WScript.Shell")
' Setting file names
strDirectory = "C:\Export"
strFile = "\" & ObjNetwork.Username & "-" & ObjNetwork.ComputerName & "-PST-Files.txt"
' Check to see if the file already exists exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder2 = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
objFile.Close
End If
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
' Opening text file
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, ForAppending, True)
For Each objFolder2 In objNS.Folders
objTextFile.WriteLine(GetPSTpath(objFolder2.StoreID))
Next
Function GetPSTPath(input)
For i = 1 To Len(input) Step 2
strSubString = Mid(input,i,2)
If Not strSubString = "00" Then strPath = strPath & ChrW("&H" & strSubString)
Next
Select Case True
Case InStr(strPath,":\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,":\")-1)
Case InStr(strPath,"\\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,"\\"))
End Select
End Function
If your GetPSTPath() function is returning the proper paths to the files you seek, and you just want to write the file sizes along with the file paths, you can do this:
For Each objFolder2 In objNS.Folders
' Get the file path...
strPath = GetPSTpath(objFolder2.StoreID)
' Get the file's size...
intSize = objFSO.GetFile(strPath).Size
' Write both pieces of information to the output file...
objTextFile.WriteLine strPath & " = " & intSize
Next
Thanks for your help and suggestions. I came up with the following which grabs the users default Outlook profile launches Outlook, verifies the attached PSTs then outs to file, including username, PST location and size. The .MDC files are excluded which relate to Enterprise Vault local cache.
Dim objNetworkSet, objFSO, objFolder, objShell, objTextFile, objFile, objWMISysEnv,ObjItem, objTextFileUNC
Dim strHomePath, strDirectory, strFile, strText, strComputerName,strDirectoryUNC,strFileUNC
dim colItems
'On Error Resume Next
Set objNetwork = CreateObject("WScript.Network")
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set WSHShell = WScript.CreateObject("WScript.Shell")
DefaultOutlookProfile = WSHShell.RegRead("HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\DefaultProfile")
'MsgBox("DefaultOutlookProfile: " & DefaultOutlookProfile)
objNS.Logon DefaultOutlookProfile, "", False, True
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Setting file names
strDirectory = "\\NetworkShare\pstlog\"
strFile = ObjNetwork.Username & "-" & ObjNetwork.ComputerName & "-PST-Files.txt"
' Check to see if the file already exists exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder2 = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
objFile.Close
End If
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForWriting = 2
' Opening text file
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, ForWriting, True)
For Each strNS In objNS.Folders
'objTextFile.WriteLine(GetPSTpath(strNS.StoreID))
strPath2 = GetPSTpath(strNS.StoreID)
'MsgBox("strPath2: " & strPath2)
If Not strPath2 = "" And Not Right(strPath2, 4) = ".mdc" Then
' Get the file's size...
intSize = FormatNumber((objFSO.GetFile(strPath2).Size/1048576), 2) & " MB"
'intSize = intSize/1024 & " MB"
' Write both pieces of information to the output file...
objTextFile.WriteLine(ObjNetwork.Username & ", " & strPath2 & ", " & intSize)
End If
Next
Public Function GetPSTPath(input)
For i = 1 To Len(input) Step 2
strSubString = Mid(input,i,2)
If Not strSubString = "00" Then strPath = strPath & ChrW("&H" & strSubString)
Next
Select Case True
Case InStr(strPath,":\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,":\")-1)
Case InStr(strPath,"\\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,"\\"))
End Select
End Function
If err.number = vbEmpty then
Else WScript.echo "VBScript Error: " & err.number
End If

VBS script find and delete file

I am trying to find a specific file on computer and delete it.
This is my code:
Const DeleteReadOnly = True
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oWshShell = CreateObject("WScript.Shell")
sDir = oWshShell.ExpandEnvironmentStrings("%temp%\dir.txt")
sFileName = "\date.vbs"
If oFSO.FileExists(sDir) Then oFSO.DeleteFile(sDir)
For Each oDrive In oFSO.Drives
if oDrive.DriveType = 2 Then Search oDrive.DriveLetter
Next
Set oFile = oFSO.OpenTextFile(sDir, 1)
aNames = Split(oFile.ReadAll, VbCrLf)
oFile.Close
For Each sName In aNames
If InStr(1, sName, sFileName, 1) > 0 Then WScript.Echo sName
Next
dim filesys
Set filesys = CreateObject("Scripting.FileSystemObject")
filesys.CreateTextFile "\date.vbs", True
If filesys.FileExists("\date.vbs") Then
filesys.DeleteFile "\date.vbs"
Wscript.Echo("File deleted")
End If
Sub Search(sDrive)
WScript.Echo "Scanning drive " & sDrive & ":"
oWshShell.Run "cmd /c dir /s /b " & sDrive & ":\" & sName & " >>" & sDir, 0, True
End Sub
The code is working only partially. When the file "date.vbs" is in root folder (C:\date.vbs) then it is deleted but when it is in folder (C:\backup\date.vbs) then it will not be deleted. Do you know which code changes I should make to be able to delete file even when it is not in root but anywhere in computer?
Thank you! V.
UPDATE:
The code is pretty much working right now. I just have a final problem of deleting the file. I am able to change the attributes from Read-only to normal but still i get the error of access denied.
This is my code:
Const DeleteReadOnly = True
Dim oFSO, oDrive, sFileName, ws, WshS, fso, usrProfile, oFolder, skypefolder
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFileName = "Skype.exe"
Set WshS = WScript.CreateObject("WScript.Shell")
usrProfile = WshS.ExpandEnvironmentStrings("%UserProfile%")
skypefolder = "C:\Program Files (x86)\Skype\"
For Each oDrive In oFSO.Drives
If oDrive.DriveType = 2 Then Recurse oFSO.GetFolder(skypefolder)
Next
Sub Recurse(oFolder)
Set oFile = CreateObject("Scripting.FileSystemObject")
Dim oSubFolder, oFile
If IsAccessible(oFolder) Then
For Each oSubFolder In oFolder.SubFolders
Recurse oSubFolder
Next
WScript.Echo oFolder.Path
For Each oFile In oFolder.Files
If oFile.Name = sFileName And oFile.Attributes And 1 Then
oFile.Attributes = 0
oFile.Delete True
End If
Next
End If
End Sub
Function IsAccessible(oFolder)
On Error Resume Next
IsAccessible = oFolder.SubFolders.Count >= 0
End Function
Thank you for help!
Code I use to run the script as ADMIN. After this it started to show the MessageBoxes. Before it was running in a console.
If WScript.Arguments.Named.Exists("elevated") = False Then
CreateObject("Shell.Application").ShellExecute "wscript.exe", """" & WScript.ScriptFullName & """ /elevated", "", "runas", 1
WScript.Quit
Else
Set oShell = CreateObject("WScript.Shell")
oShell.CurrentDirectory = CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName)
'WScript.Echo("Now running with elevated permissions")
End If
So I believe there is something wrong in this code.
Your approach is much too complicated. Use a simple recursive function:
Option Explicit
Const DeleteReadOnly = True
Dim oFSO, oDrive, sFileName
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFileName = "date.vbs"
For Each oDrive In oFSO.Drives
If oDrive.DriveType = 2 Then Recurse oDrive.RootFolder
Next
Sub Recurse(oFolder)
Dim oSubFolder, oFile
If IsAccessible(oFolder) Then
For Each oSubFolder In oFolder.SubFolders
Recurse oSubFolder
Next
For Each oFile In oFolder.Files
If oFile.Name = sFileName Then
'oFile.Delete ' or whatever
End If
Next
End If
End Sub
Function IsAccessible(oFolder)
On Error Resume Next
IsAccessible = oFolder.SubFolders.Count >= 0
End Function
To achieve case-insensitive file name comparison, you could use
If StrComp(oFile.Name, sFileName, vbTextCompare) = 0 Then
As an exercise: You can also use the WMI Service to find certain files. You don't have to go through all folders, you just query the file on any drive, on any folder:
Function find_file(filename)
Dim objWMIService, colItems, objItem, strComputer
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM CIM_DataFile WHERE FileName='" & filename & "'",,48)
For Each objItem in colItems
msgbox "Found " & objItem.Name & " in " objItem.Path
Next
End Function
Note: It can take long before the function has returned its results.

Resources