Jump to content

VBS Drop then Copy

gunsmokingman
 Share

Recommended Posts

gunsmokingman

gunsmokingman

Posted
Posted (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.vbs

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  
   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 If

This one you can select a CopyTo spot or use the default location

Save As DropSelectCopyTo.vbs

Option 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 Function

CopyToVbs.exe

Edited by gunsmokingman
Link to comment
Share on other sites
  • 4 weeks later...

Stealth111

Stealth111

Posted
Posted

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
Stealth111

Stealth111

Posted
Posted

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
gunsmokingman

gunsmokingman

Posted
  • Author
Posted

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 If

This 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
gunsmokingman

gunsmokingman

Posted
  • Author
Posted

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.vbs

Dim 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
Stealth111

Stealth111

Posted
Posted

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

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 account

Sign in

Already have an account? Sign in here.

Sign In Now
 Share
Go to topic listing

  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...