VBS If file is open - vbscript

I've got a simple program than scans data into a spreadsheet along with a timestamp, then you can either update the data by saving, or quit and exit and save.
The only issue I've been stuck on for a day or so is to work around the error handling of the case of the spreadsheet being already open. Id like to have something like this;
if file is open THEn msgbox("File is open, close file and start again")
WScript.Quit
Option Explicit
DIM oFs: Set oFs = CreateObject("Scripting.FileSystemObject")
DIM objExcel, strExcelPath, objSheet
DIM ib
DIM msg1
DIM msg2
strExcelPath = "c:\temp\Example.xls"
Set objExcel = CreateObject("Excel.Application")
objExcel.WorkBooks.Open strExcelPath
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
DO
ib=inputbox("SCAN NAME, SCAN LOTS"&vbCrLf&"TO UPDATE,SCAN ""UPDATE."""&vbCrLf&"TO EXIT, SCAN ""QUIT.""","Picklot Passout Database")
IF ib="" THEN
msg1=MsgBox("You must scan either a NAME or LOT NUMBER."&vbCrLf&"If you want to exit, scan QUIT."&vbCrLf&"Click OK to continue.",vbokonly,"Cannot Insert Blank Data")
ELSEIF ib= "QUIT" OR ib= "quit" THEN
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
set objExcel = Nothing
Set oFs = Nothing
ELSEIF ib="update" OR ib="UPDATE" THEN
objExcel.ActiveWorkbook.Save
msg2=MsgBox("Update Complete.",vbokonly,"Database Updated")
ELSE
objSheet.Range("A2").EntireRow.Insert
objSheet.Cells(2, 1).Value = ib
objSheet.Cells(2, 2).Value=(now)
END IF
LOOP WHILE NOT ib="quit" AND NOT ib="QUIT"

This may help point you in the right direction. Sorry for the rushed, lowercase syntax and unconventional indentations (do not follow my bad practice - keep yours! :D), I wrote it in notepad you see - but it has been tested successfully.
Anyhow, with reference to your code, I have restructured it in a bad manner, familiar to me, adding the functionality you specify. Essentially the task manager application list is checked for a running instance of the "example" Excel file (depending on what version of excel you're using the syntax will differ).
If found it will make it the active window (thereby preventing a read only duplicate instance initiating). If no instance is found it will open "example.xlsx", in this case using a relative path to the script itself. A subroutine is then called to do the business with the cells...
I have written it in such a way to try keep your specs as well as maintain the "OK" and "Cancel" buttons explicitly functional. Please feel free to tinker with this, you may need to address the path and instr lines differently. I hope it helps! All the best.
path=createobject("scripting.filesystemobject").getparentfoldername(wscript.scriptfullname)
excelpath=path&"\example.xlsx"
set objword=createobject("word.application")
set coltasks=objword.tasks
i=0
for each objtask in coltasks
name=lcase(objtask.name)
if instr(name, "microsoft excel - example") then
i=1
end if
next
if i=1 then
wscript.echo "An active instance of ""example.xlsx"" has been found"
set objexcel=getobject(excelpath)
call UPDATER
else
set objexcel=createobject("excel.application")
objexcel.workbooks.open(excelpath)
set objsheet=objexcel.activeworkbook.worksheets(1)
objexcel.visible=true
call UPDATER
end if
sub UPDATER
do
data=inputbox("Please enter data" &vbcrlf&vbcrlf& "To save data & continue, type ""update""" &vbcrlf& "To save data & exit, type ""quit""","Excel DB Updater")
if isempty(data) then
objexcel.activeworkbook.close
objexcel.application.quit
wscript.quit()
elseif lcase(data)="quit" then
objexcel.activeworkbook.save
objexcel.activeworkbook.close
objexcel.application.quit
quit=msgbox("DB Updating complete",vbokonly,"Excel DB Updater")
wscript.quit
elseif lcase(data)="update" then
objexcel.activeworkbook.save
update=msgbox("Data save complete, press OK to continue",vbokonly,"Excel DB Updater")
elseif len(data)<>0 then
objsheet.range("A1").entirerow.insert
objsheet.cells(1, 1).value=data
objsheet.cells(1, 2).value=(now)
add=msgbox("Data added, press OK to continue",vbokonly,"Excel DB Updater")
end if
loop while len(data)>=0 and not lcase(data)="quit"
end sub

Related

VB6 Update Error Sheridan Grid

I'm making some changes to a program that was written by another developer, which uses an SSDB Grid.
I'm writing the code for the BeforeUpdate method.
On Error GoTo BeforeUpdate_Err
Dim ans%
ans% = MsgBox("These changes will be committed to the database. These changes cannot be undone. " & _
"Would you like to continue?", vbYesNo, "Confirm Changes")
If ans% = 7 Then
Grd_Collection.CancelUpdate
End If
Exit Sub
BeforeUpdate_Err:
MsgBox (Err.Description)
The only other code for the grid is the InitColumnProps method.
However, after hitting the Exit Sub line, I get an error message "Update Error".
I've searched the code for this being hard-coded but it isn't, so it's coming from the grid.
What is causing the error and how do I fix it?
Doesn't the BeforeUpdate method pass in an integer? (Cancel As Integer) or something?
Therefore, you should just be able to change your code (and tidy it up) to this:
On Error GoTo BeforeUpdate_Err
If MsgBox("These changes will be committed to the database. These changes cannot be undone. " & _
"Would you like to continue?", vbYesNo, "Confirm Changes") = vbNo Then
Cancel = 1
End If
Exit Sub
BeforeUpdate_Err:
MsgBox (Err.Description)

How to disable SmartScreen for a specific .cmd file?

I recent made a group of .cmd files.
Called, 'Node.1.cmd' and 'Node.2.cmd', the files' purpose was supposed to open each other (in a chain-like process).
However, whenever I open one of the 2, it gives me a seriously annoying message:
Windows Protected your PC.
Windows SmartScreen prevented an unrecognized app from starting. Running this app may put your PC at risk.
I agree that this is a bit risky, but it was made for fun, not for destruction. It was just my way of showing people not to mess with my stuff. Not even did I set any LNK at my desktop to the file.
Now, to get to the point, can I exclude this file from SmartScreen while keeping it on?
Because of this, I have problems opening it with a .vbs file
To be more specific, it opens but then automatically closes with a message:
The system cannot find the path specified.
Does windows SmartScreen encrypt the file or something like that?
I scripted the following:
Titre = "What would you like to do ? RookieTEC9©"
message = "What would you like to do ?"&vbcr&vbcr&_
"1 - Launch Project Node "&vbcr&_
"2 - Launch Golden Chrome"&vbcr&_
"3 - Launch An Application"&vbcr&_
"4 - Start Windows Update"&vbcr&_
"5 - Slide2Kill"
Default ="1"
Question = InputBox(message,Titre,Default)
Select Case Question
Case 1 Run(1)
Case 2 Run(2)
Case 3 Run(3)
Case 4 Run(4)
Case 5 Run(5)
end Select
Sub Run(var)
Set WS = CreateObject("WScript.shell")
Select Case var
Case 1 WS.run("explorer.exe /e,C:\Users\Jeremi\OneDrive\Happy_files\Unsorted_Files\Project_Node.zip\Node.1.cmd")
Case 2 ProcessNotNeeded()
Case 3 LaunchApplication()
Case 4 WindowsUpdate()
Case 5 WS.run("SlideToShutDown.exe")
End select
End Sub
Sub Kill(Process)
Set Ws = CreateObject("Wscript.Shell")
Command = "cmd /c Taskkill /F /IM "&Process&""
Execution = Ws.Run(Command,0,False)
End Sub
Sub ProcessNotNeeded()
Titre = "Killing Process Not Needed RookieTEC9© "
message = "Type the Name of the process to be killed by this script"&vbcr&_
"Example To Kill The Internet Explorer Process You should type"&vbcr&_
"iexplore.exe"
Default ="iexplore.exe"
Question = InputBox(message,Titre,Default)
Kill(Question)
End Sub
Function CmdPrompt(sCmd)
Dim sCmdLine,oWS,nRes
set oWS = CreateObject("Wscript.Shell")
sCmdLine = "cmd /c Start " & sCmd & ""
nRes = oWS.Run(sCmdLine,0,False)
CmdPrompt = nRes
End Function
Sub LaunchApplication()
Titre = "Launching an Application"
message = "Type the Name of the process to be Lanuched by this script"&vbcr&_
"Example To Launch The Word Application You should type"&vbcr&_
"Winword.exe"
Default ="Winword.exe"
Question = InputBox(message,Titre,Default)
CmdPrompt(Question)
End Sub
Sub WindowsUpdate()
Title = "Checking for Windows updates"
Msg = "Looking for a list of updates, So be Patient Thank you !"
Wait = "70" 'waiting 70 secondes to close the popup
Set Ws = CreateObject("Wscript.Shell")
ws.Popup Msg,wait,Title,64
Set updateSession = CreateObject("Microsoft.Update.Session")
Set updateSearcher = updateSession.CreateupdateSearcher()
Set searchResult = updateSearcher.Search("IsInstalled=0 and Type='Software'")
If searchResult.Updates.Count <> 0 Then 'If updates were found
'so with this loop shows how you can list the title of each update that was found.
For i = 0 To searchResult.Updates.Count - 1
Set update = searchResult.Updates.Item(i)
ws.Popup update.Title,wait,Title,64
Next
End If
Ws.Run "wuauclt.exe /reportnow /detectnow",1,False
End Sub
Sorry for the long code!
To be 100% honest, I didn't create this from scratch, I just edited it.
I am new to VBS
However, if you have any questions on HTML or CSS, I may be able to answer it.
Please keep in mind that I am a 5th grader and only started coding this school year.
THX for your time and answer.
P.S.
Also, the file was in a zip. Does that effect it?
You can unblock these CMD files, it is explained here
Once unblocked you should be able to run it from the console and from your script.
I myself scripted a very long time in vbscript but now it is obsolete. Since you have
just started to learn, I advise you to learn another scripting language like Ruby which is fun to learn or if you want to go the 'only windows' way Powershell (shiver..)

VBScript/Classic ASP permission denied with fso.OpenTextFile after several uses

I have a process that loops through a moderate amount of data (1MB) storing it in an array and then periodically writes it to the disk. After several iterations, the script fails at fso.OpenTextFile() in my else section as though the file has not been closed or finished closing from the previous time the function was called. The iteration # doesn't seem to be specific as it's happened anywhere between the 2nd and 10th iteration that I can tell. The file is actually created and being appended to so it doesn't appear to be a permissions issue. I considering adding a time delay to the process but don't want to necessarily add overhead to an already long process.
OS: Windows 2012 R2
Any thoughts or suggestions appreciated.
'Write array to disk
sub writeFile()
'on error resumenext
set fso = Server.CreateObject("Scripting.FileSystemObject")
if needToCreateFile then
set objTextFile = fso.CreateTextFile(server.mappath("google/linklist.html"),true)
objTextFile.writeLine("<!DOCTYPE html>")
objTextFile.writeLine("<html>")
objTextFile.writeLine("<title>")
objTextFile.writeLine("Content Listing")
objTextFile.writeLine("</title>")
needToCreateFile = false
else
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Set objTextFile = fso.OpenTextFile (filename, ForAppending, True)
end if
'Write contents of array to file
for each link in linkList
if link <>"" and not isNull(link) then
objTextFile.writeLine(link & "<br>")
end if
next
objTextFile.writeLine("</html>")
objTextFile.Close
set fso = nothing
set objTextFile = nothing
'on error goto 0
end sub
Follow Up - Solved
Adding a 3 second delay solved the problem, but significantly delayed the processing time. So, rather than opening and closing the file each time I wanted to write to it, I simply left it open until the entire script was done and thus I didn't need the delay.
sub writeFile()
if needToCreateFile then
set objTextFile = fs.CreateTextFile(server.mappath("google/linklist.html"),true)
objTextFile.writeLine("<!DOCTYPE html>")
objTextFile.writeLine("<html>")
objTextFile.writeLine("<title>")
objTextFile.writeLine("Content Listing")
objTextFile.writeLine("</title>")
needToCreateFile = false
end if
'Write contents of array to file
for each link in linkList
if link <>"" and not isNull(link) then
objTextFile.writeLine(link & "<br>")
end if
next
objTextFile.writeLine("</html>")
' objTextFile.Close
' set fso = nothing
' set objTextFile = nothing
end sub
Adding a 3 second delay solved the problem, but significantly delayed the processing time. So, rather than opening and closing the file each time I wanted to write to it, I simply left it open until the entire script was done and thus I didn't need the delay. See modified script above.

QTP Link object does not support the Exist property

I have a weird problem with QTP 11. The following piece of code worked so far, but suddenly stopped working and throws Object does not support this property or method.: 'objPage.Link' for the line with 'if link exist'
Set objBrowser = Browser("creationtime:=" & Desktop.ChildObjects(oDesc).Count - 1 & "")
Set objPage = objBrowser.Page("title:=.*")
If objPage.Link("class:=menu_link_tab_.*", "html id:=.*DesktopTab").Exist(3) Then
msgbox "ok"
End If
Can anyone tell me what is wrong and/or how to do it right?
EDIT: I solved this but still have no idea what happened. I just cut this part from QTP script and pasted it into Notepad and then copied it from Notepad to QTP. Everything works fine. I did not change anything... Any ideas what the hell happened are welcomed.
ANOTHER EDIT: The problem reappears randomly. With no changes to anything I can just run the test 10 times to have it fail randomly with the 'Object does not support this property or method' message
I have a startBrowser function where I set the objPage and objBrowser :
Function startBrowser(vURL)
Dim oDesc
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate vURL
Window("hwnd:=" & IE.HWND).Maximize
Set oDesc = Description.Create
oDesc( "micclass" ).Value = "Browser"
If Desktop.ChildObjects(oDesc).Count > 0 Then
Set objBrowser = Browser("creationtime:=" & Desktop.ChildObjects(oDesc).Count - 1 & "")
End If
Set objPage = objBrowser.Page("title:=.*")
End Function
I have added lots of msgboxes with GetROProperty to verify whether the objects are ok. They seem to be.
Now my function to click the link looks like this :
Function clickMainMenuLink(vIdentifier)
Set objLink = objPage.Link("class:=menu_link_tab_.*", "html id:=.*" & vIdentifier, "index:=0")
If objLink.Exist(timeOut) Then
objLink.Click
Else
reporter.ReportEvent micFail, "Click the " & vIdentifier & " menu link", "Cannot find the " & vIdentifier & " menu link"
ExitTestIteration
End If
End Function
So at the moment my test just opens the browser and clicks a link as I try to debug the thing, but it still fails or passes randomly. The run error indicates line with 'Set objLink'. Any ideas for further debugging? I'm on QTP11 and IE8 if it matters.
From your error does not support this property or method: objPage.Link it would appear that the problem isn't with the .Exist part of line but the .Link part (you can verify this by separating the line into two lines and see which fails
set objLink = objPage.Link("class:=menu_link_tab_.*", "html id:=.*DesktopTab")
If objLink.Exist(3) Then
From your comment it seems that you're creating objPage in a different location from where you're using it, I suggest making sure that the object arrives OK.
Thanks Motti, your reasoning was right. The problem was with the objPage part. Despite the fact that I could read every property of objPage in a function QTP sometimes just did not see this objPage as a Page object. I guess it has something to do with not declaring type explicitly, but that's just a guess. As a dirty workaround I set up the objBrowser and objPage in every function now and it works 100%.

VBScript mysterium - Why isn't network drives connected at logon?

This is one of the strangest things I've ever seen. I've got this logon script that basically disconnects a set of Network drives and then reconnects them. Previously, all users had a batch file set in their AD profile to run. After I wrote the vbscript, I just run that via the batch script. And it's been working just fine.
Now however, I tried to create a GPO and set the vbscript directly in there. And strangely enough, no network drives are connected. So I began poking around, puttinga msgbox right before the drives are connected. And one right after. Immediatly after login I can see the first textbox appear. After I click OK, the drives are supposed to be connected. But they don't. And right after, I can see the second text box.
What's really weird is that if I run the script manually directly after, everything works just fine! I even tried to put a sleep command on the top of the script now, just in case there's some mismatch in the replication of the domain controllers. But that didn't do anything either.
Here's the script as it is right now:
'Run the script
mapNetworkdrives
Public Sub mapNetworkdrives()
' Lag WScript.Network-objekt
Set objNetwork = CreateObject("WScript.Network")
Set objFso = CreateObject("Scripting.FileSystemObject")
'On Error Resume Next
' Fjern eksisterende nettverksdrev først
removeNetworkDrives objFSO, objnetwork
Dim userName
userName = objNetwork.UserName
Dim computerName
computerName = objNetwork.ComputerName
' Sjekk om det er Citrix som blir logget på
If computerName = "JBC" Then
If Not isDriveConnected("S", objFso, objNetwork) = True Then
objNetwork.MapNetworkDrive "S:", "\\sharepoint.ourcompany.no\prosj"
End if
End if
' Sjekk om nettverksdrev er allerede koblet opp
'objNetwork.MapNetworkDrive "Z:", "\\ourcompany.local\files\Brukere\" & username
objNetwork.MapNetworkDrive "P:", "\\ourcompany.local\files\felles"
objNetwork.MapNetworkDrive "Q:", "\\ourcompany.local\files\maler"
objNetwork.MapNetworkDrive "R:", "\\ourcompany\DIY"
objNetwork.MapNetworkDrive "N:", "\\ourcompany\felles\navn"
Set objNetwork = Nothing
Set objFSO = Nothing
End Sub
Public Sub removeNetworkDrives(ByVal objFSO, ByVal objNetwork)
'On Error Resume Next
If isDriveConnected("Z", objFSO) Then
objNetwork.RemoveNetworkDrive "Z:", True, True
End if
If isDriveConnected("P", objFSO) = True Then
objNetwork.RemoveNetworkDrive "P:", True, True
End if
If isDriveConnected("Q", objFSO) = True Then
objNetwork.RemoveNetworkDrive "Q:", True, True
End if
If isDriveConnected("R", objFSO) = True Then
objNetwork.RemoveNetworkDrive "R:", True, True
End if
If isDriveConnected("N", objFSO) = True Then
objNetwork.RemoveNetworkDrive "N:", True, True
End if
Set objNetwork = Nothing
End Sub
Can anybody see anything that I cannot? Am I missing something here? The very same script works just fine if I run the batch file first, which again runs this very same script. The only thing I can think of is that some DNS server might not be ready or something at the time the script is run.
Turns out, this is "normal behaviour" as described here:
http://pcloadletter.co.uk/tag/launchapp-wsf/
It is worth trying checking the privileges of the script.
I've encountered a lot of network shared mapping issues with scheduled/automatic scripts.
Personally, I use batch's "net use" and it solved many weird issues.

Resources