gunsmokingman Posted August 24, 2006 Share Posted August 24, 2006 (edited) Here are 2 VBS scripts that copy a file when a file is placed on the VBS script.1:\ It uses WScript.Arguments(0) to get the Path and Name of the file.2:\ It uses this as a default location for the copy to spot or the second script has a Inputbox if you want to use another spot. Dim FldrDate : FldrDate = WeekdayName(Weekday(Date),True) & "-" & Replace(Date,"/","-") Dim SysCopy : SysCopy = Act.ExpandEnvironmentStrings("%SystemDrive%\Arch_CopyTo_" & FldrDate &"\")This VBS script does not have a Inputbox to set the CopyTo Location It uses the above as default.Save As DropAndCopyFile.vbsOption Explicit Dim ObjFile, strDestination Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject") Dim Act : Set Act = CreateObject("Wscript.Shell") Dim FldrDate : FldrDate = WeekdayName(Weekday(Date),True) & "-" & Replace(Date,"/","-") Dim SysCopy : SysCopy = Act.ExpandEnvironmentStrings("%SystemDrive%\Arch_CopyTo_" & FldrDate &"\") Dim ArgCnt : ArgCnt = WScript.Arguments.Count If ArgCnt = 1 Then'/-> Passes The Full Path And File Name As A Argument Set ObjFile = Fso.GetFile(Wscript.Arguments(0))'/-> Get It Name From The Drag And Drop strDestination = SysCopy & ObjFile.Name '/-> Check For The destination Folder If Not Fso.FolderExists(SysCopy) Then Fso.CreateFolder(SysCopy) End If '/-> Set To Over Write File If Exists ObjFile.Copy(strDestination),True Act.Popup "Completed The Copy From" & vbCrLf & Wscript.Arguments(0) & vbCrLf &_ "To This Location Here" & vbCrLf & strDestination, 5, "Copy Completed",0 + 32 + 48 Else'/-> If No File Was Drop On To The Script Act.Popup "Error No File Was Drop On This Script" & _ "To Copy The File It Must Be Place On" & vbCrLf & _ WScript.ScriptFullName, 15,"Error", 0 + 48 + 4096 Wscript.Quit End IfThis one you can select a CopyTo spot or use the default locationSave As DropSelectCopyTo.vbsOption Explicit Dim Loc, ObjFile, strDestination, WsArg1, WsArg2 Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject") Dim Act : Set Act = CreateObject("Wscript.Shell") Dim FldrDate : FldrDate = WeekdayName(Weekday(Date),True) & "-" & Replace(Date,"/","-") Dim SysCopy : SysCopy = Act.ExpandEnvironmentStrings("%SystemDrive%\Arch_CopyTo_" & FldrDate &"\") Dim ArgCnt : ArgCnt = WScript.Arguments.Count'/--> Check To Make Sure You drop The File On The script If ArgCnt = 1 Then WsArg1 = WScript.Arguments(0) Set ObjFile = Fso.GetFile(WsArg1) Loc = InputBox ("Type in the Location where you would like to copy this file to " &_ Chr(62) & " " & ObjFile.Name & vbCrLf & vbCrLf &_ Space(7) & "Example Of Correct Path" & vbCrLf &_ "Correct Path " & Chr(62) & " C:\" & vbCrLf &_ "Correct Path " & Chr(62) & " D:\CopyToNewFolder" & vbcrlf &_ "Correct Path " & Chr(62) & " E:\Windows\CopyToNewFolder" & vbcrlf &_ "This will make only One New Folder, if the New Folder does not exists in the CopyTo path" & vbCrLf &_ vbcrlf & Space(7) & "Example Of Wrong Path" & vbCrLf &_ "Wrong Path " & Chr(62) & " F:\NewFolder1\NewFolder2" & vbCrLf &_ "Will not make 2 new folders in the CopyTo path" & vbCrLf &vbCrLf &_ "If the text box is left blank and you press the OK or" & vbCrLf &_ "Cancel then the script uses this location to copy to" & vbCrLf & SysCopy & vbCrLf &_ vbCrLf & UCase("Type Quit To Exit And Not Copy The File") ,"Select Copy To spot",,5500.4800) If Loc = "" Then WsArg2 = SysCopy strDestination = "Default Copy To Location" & vbCrLf & SysCopy & ObjFile.Name CopyTheFile End If '/--> If User Type Quit, Checks For Three Different Spellings Of QUIT If InStr(Loc, "QUIT") Then : WScript.Quit : End If If InStr(Loc, "Quit") Then : WScript.Quit : End If If InStr(Loc, "quit") Then : WScript.Quit : End If '/--> User Selects The Copy To Spot If Loc <> "" Then Loc = Loc & "\"'/--> To Check For Double BackSlash And Make It A Singe BackSlash If InStr(Loc,"\\") Then WsArg2 = Replace(Loc,"\\","\") strDestination ="User Select Copy To Location" & vbCrLf & WsArg2 & ObjFile.Name CopyTheFile Else '/--> If There Is A Single BackSlash strDestination = "User Select Copy To Location" & vbCrLf & Loc & ObjFile.Name WsArg2 = Loc CopyTheFile End If End If Else '/-> If No File Was Drop On To The Script Act.Popup "Error No File Was Drop On This Script " & _ "To Copy The File It Must Be Place On" & vbCrLf & _ WScript.ScriptFullName, 15,"Error", 0 + 48 + 4096 Wscript.Quit End If '/--> Copy The Drop File To New Location Function CopyTheFile'/--> Check To Make Sure The CopyTo Folder Is There, If Not It Makes It If Not Fso.FolderExists(WsArg2) Then Fso.CreateFolder(WsArg2) End If '/--> Copy The File And Over Write It If It Exists ObjFile.Copy(WsArg2 & ObjFile.Name ),True Act.Popup "Completed The Copy From" & vbCrLf & Wscript.Arguments(0) & vbCrLf &_ "To This Location Here " & strDestination, 7, "Copy Completed",0 + 48 + 4096 End FunctionCopyToVbs.exe Edited August 27, 2006 by gunsmokingman Link to comment Share on other sites More sharing options...
Stealth111 Posted September 18, 2006 Share Posted September 18, 2006 Could the code be modified somehow to copy the file dragged to 3 seperate locations at the same time?? Like to 3 different servers?? This worked great for me to copy changed files to a server easily, but I have multiple servers I would like to synch with a newly created file everyday, like when I make changes to the file, it would be way cool to drag it to the .vbs file and have it copy to 3 seperate locations.. Any help would be greatly appreciated!! :0 Link to comment Share on other sites More sharing options...
gunsmokingman Posted September 19, 2006 Author Share Posted September 19, 2006 I will see what I can do about that. Link to comment Share on other sites More sharing options...
Stealth111 Posted September 19, 2006 Share Posted September 19, 2006 Sweet!! Thanks again!! Link to comment Share on other sites More sharing options...
Stealth111 Posted September 23, 2006 Share Posted September 23, 2006 Any luck Gun?? Link to comment Share on other sites More sharing options...
gunsmokingman Posted September 23, 2006 Author Share Posted September 23, 2006 I can get it to copy to 3 different spots that not the problem.What it needs to do is1:\ Ping the server to make sure it online2:\ Copy the file to the server if it online. Link to comment Share on other sites More sharing options...
Stealth111 Posted October 1, 2006 Share Posted October 1, 2006 Sounds like a great idea, hope you can get it worked out!! Any chance you can throw the fix at me that will allow it to just attempt the blind copy to 3 different locations(servers) in the meantime while you are working out the other method?? Please. And Thanks!! Link to comment Share on other sites More sharing options...
gunsmokingman Posted October 2, 2006 Author Share Posted October 2, 2006 This will copy the file to 3 new folders on %SystemDrive%Option Explicit Dim ObjFile, strDestination Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject") Dim Act : Set Act = CreateObject("Wscript.Shell") Dim FldrDate : FldrDate = WeekdayName(Weekday(Date),True) & "-" & Replace(Date,"/","-") Dim SysCopy : SysCopy = Act.ExpandEnvironmentStrings("%SystemDrive%\Arch_CopyTo_" & FldrDate) Dim ArgCnt : ArgCnt = WScript.Arguments.Count Dim Cnt, CopyTo If ArgCnt = 1 Then Do Cnt = Cnt + 1 Set ObjFile = Fso.GetFile(Wscript.Arguments(0)) CopyTo = SysCopy & "_" & Cnt & "\" strDestination = CopyTo & ObjFile.Name If Not Fso.FolderExists(CopyTo) Then Fso.CreateFolder(CopyTo) End If ObjFile.Copy(strDestination),True Act.Popup "Completed The Copy From" & vbCrLf & Wscript.Arguments(0) & vbCrLf &_ "To This Location Here" & vbCrLf & strDestination, 5, "Copy Completed",0 + 32 + 48 Loop Until Cnt = 3 Else Act.Popup "Error No File Was Drop On This Script" & _ "To Copy The File It Must Be Place On" & vbCrLf & _ WScript.ScriptFullName, 15,"Error", 0 + 48 + 4096 Wscript.Quit End IfThis one copies to 3 different drives Option Explicit Dim ObjFile, strDestination Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject") Dim Act : Set Act = CreateObject("Wscript.Shell") Dim FldrDate : FldrDate = WeekdayName(Weekday(Date),True) & "-" & Replace(Date,"/","-") Dim ArgCnt : ArgCnt = WScript.Arguments.Count Dim Cnt, CopyRpt, CopyTo If ArgCnt = 1 Then Do CopyRpt = CopyRpt & strDestination & vbCrLf Cnt = Cnt + 1 Set ObjFile = Fso.GetFile(Wscript.Arguments(0)) If Cnt = 1 Then CopyTo = "D:\Archive_" & FldrDate & "_" & Cnt & "\" strDestination = CopyTo & ObjFile.Name If Not Fso.FolderExists(CopyTo) Then Fso.CreateFolder(CopyTo) End If ObjFile.Copy(strDestination),True End If If Cnt = 2 Then CopyTo = "E:\Archive_" & FldrDate & "_" & Cnt & "\" strDestination = CopyTo & ObjFile.Name If Not Fso.FolderExists(CopyTo) Then Fso.CreateFolder(CopyTo) End If ObjFile.Copy(strDestination),True End If If Cnt = 3 Then CopyTo = "F:\Archive_" & FldrDate & "_" & Cnt & "\" strDestination = CopyTo & ObjFile.Name If Not Fso.FolderExists(CopyTo) Then Fso.CreateFolder(CopyTo) End If ObjFile.Copy(strDestination),True End If If Cnt = 4 Then Act.Popup "Completed The Copy From" & vbCrLf & Wscript.Arguments(0) & vbCrLf &_ "To This Location Here" & CopyRpt, 5, "Copy Completed",0 + 32 + 48 End If Loop Until Cnt = 4 Else Act.Popup "Error No File Was Drop On This Script" & _ "To Copy The File It Must Be Place On" & vbCrLf & _ WScript.ScriptFullName, 15,"Error", 0 + 48 + 4096 Wscript.Quit End If Link to comment Share on other sites More sharing options...
gunsmokingman Posted October 2, 2006 Author Share Posted October 2, 2006 Could you try this script as I have no network to test this on. Just replace this ("127.0.0.1","5.9.5.5","25.29.125.325") these with the correct addresses of the computers you want to copy to.Save As PingComputer.vbsDim ArrComp, Cnt, ConFirm, Missing, ObjExec, StrAC, strComputer, StrPing Dim Act : Set Act = CreateObject("WScript.Shell") ArrComp = Array("127.0.0.1","5.9.5.5","25.29.125.325") PingComputers() Function PingComputers() For Each StrAC In ArrComp strComputer = StrAC Set ObjExec = Act.Exec("ping -n 2 -w 1000 " & strComputer) StrPing = LCase(ObjExec.StdOut.ReadAll) If InStr(StrPing, "reply from") Then If InStr(StrPing, "destination net unreachable") Then NoReplyFromComputer() Else RunWMIQuerry() End If Else NoReplyFromComputer() End If Next Exit Function End Function '/-> Dim ColOS, ObjOS, ObjWMI Function RunWMIQuerry() ConFirm = strComputer & " has responded to the ping cmd." strComputer = StrAC Set ObjWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _ & strComputer & "\root\cimv2") Set ColOS = ObjWMI.ExecQuery("Select * from Win32_OperatingSystem") For Each ObjOS in ColOS ConFirm = ConFirm & vbCrLf & "Windows Folder: " & ObjOS.WindowsDirectory &_ vbCrLf & "Windows Drive : " & ObjOS.SystemDirectory Next Act.Popup ConFirm, 5,"Confirm Computer", 0 + 32 + 4096 Exit Function End Function '/-> Function NoReplyFromComputer() Cnt = 1001 Missing = Missing & vbCrLf & strComputer & " > Did not respond to the ping cmd." &_ vbCrLf & "This computer appears to be off line, retry this script" &_ vbCrLf & "when the computer is online" & vbCrLf Exit Function End Function If Cnt = 1001 Then Act.Popup Space(9) & Chr(62) & " Error Could Not Ping" &_ vbCrLf & Missing, 0, "Error", 0 + 32 + 4096 End If Link to comment Share on other sites More sharing options...
Stealth111 Posted October 3, 2006 Share Posted October 3, 2006 Absolutely , I will try all these first thing in the morning when I get to work.. I really appreciate the work you put into trying to get this up and running.. I will report back the results ASAP.. Link to comment Share on other sites More sharing options...
Stealth111 Posted October 7, 2006 Share Posted October 7, 2006 Well the ping script had a few different results.. My Own machine was fine, pinging local domain controller was fine, and a few of the clients in the local building reported fine, others get error at line 27 char 5 permission denied: 'getObject" code 800A0046, others give me the message error could not ping ect.ect.ect.... The computers that ARE joined to my domain work well, the ones that are on a workgroup get the permission denied, and the machines that are in another building with a different ip range give me the could not ping error, or permission denied.. (local building is 10.80.60.xxx other building is 10.80.50.xxx) and I can ping these other machines in the other building with normal programs..weird..Maybe you could script in some different priveledges, so I could try running it as the administrator of the domain as I do with all my other programs I run.. That seems to help get past priveledges about all of the time.. :)And all of our network attached storage devices gives me "the remote server machine does not exist or is unavailable: getObject" I am mainly trying to do the copy thing I mentioned to 3 different storage servers in 3 different buildings, and to 3 different servers in 3 different buildings.. Just letting you know the results as you asked..!! I really appreciate the time you are putting into these for me and anyone else it may help.. Link to comment Share on other sites More sharing options...
Recommended Posts
Create an account or sign in to comment
You need to be a member in order to leave a comment
Create an account
Sign up for a new account in our community. It's easy!
Register a new accountSign in
Already have an account? Sign in here.
Sign In Now