Di seguito il listato di un VBScript che fa le seguenti attività:
1.Mappatura Share di Rete
2.Copia dei file dalla cartella localle (Sorgente) alla share di rete (Destinazione)
3.Archiviazione (Spostamento) dei file copiati dalla cartella sorgente ad un’altra cartella
4.Check sui vari Step precedentemente descritti
5.Invio Mail inserendo all’interno del corpo del messaggio il percorso dei file copiati
I campi da modificare sono i seguenti:
|
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
Dim Cartella: Cartella = "S:\Applicativi\" strRemotePath = "\\server\Scarico" strUser = "User" strPassword = "Password" objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "server SMTP" Option Explicit Main Sub Main Dim Cartella: Cartella = "S:\Applicativi\" Dim Path: Path = Cartella & "*.*" Dim Message: Message="" Dim a: a = ListDir(Path) If (UBound(a) = -1) then WScript.Echo "No files found." Exit Sub End If Dim FileName Dim objNetwork Dim strDriveLetter, strRemotePath, strUser, strPassword, strProfile ' Values of variables set strDriveLetter = "X:" strRemotePath = "\\server\Scarico" strUser = "User" strPassword = "Password" strProfile = "false" 'Mappatura percorso di rete Set objNetwork = WScript.CreateObject("WScript.Network") objNetwork.MapNetworkDrive strDriveLetter, strRemotePath, strProfile, strUser, strPassword 'Ciclo sui file Dim FSO: Set FSO =CreateObject("scripting.FileSystemObject") For Each FileName In a FSO.CopyFile FileName , Replace(FileName,Cartella,"X:\"), True FSO.MoveFile FileName , Replace(FileName,Cartella,"S:\Applicativi\Test\") Message = Message + FileName + chr(13) Next 'Eliminazione mappatura del drive X objNetwork.RemoveNetworkDrive strDriveLetter if (Message<>"") then Dim objMessage: Set objMessage = CreateObject("CDO.Message") objMessage.Subject = "Copia Dati Test" objMessage.TextBody = "Copia effettuata con successo." + chr(13) & Message objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "server SMTP" objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 objMessage.Configuration.Fields.Update objMessage.Send WScript.Echo "Mail inviata" end if End Sub Public Function ListDir (ByVal Path) Dim fso: Set fso = CreateObject("Scripting.FileSystemObject") If Path = "" then Path = "*.*" Dim Parent, Filter if fso.FolderExists(Path) then ' Path is a directory Parent = Path Filter = "*" Else Parent = fso.GetParentFolderName(Path) If Parent = "" Then If Right(Path,1) = ":" Then Parent = Path: Else Parent = "." Filter = fso.GetFileName(Path) If Filter = "" Then Filter = "*" End If ReDim a(10) Dim n: n = 0 Dim Folder: Set Folder = fso.GetFolder(Parent) Dim Files: Set Files = Folder.Files Dim File For Each File In Files If CompareFileName(File.Name,Filter) Then If n > UBound(a) Then ReDim Preserve a(n*2) a(n) = File.Path n = n + 1 End If Next ReDim Preserve a(n-1) ListDir = a End Function Private Function CompareFileName (ByVal Name, ByVal Filter) ' (recursive) CompareFileName = False Dim np, fp: np = 1: fp = 1 Do If fp > Len(Filter) Then CompareFileName = np > len(name): Exit Function If Mid(Filter,fp) = ".*" Then ' special case: ".*" at end of filter If np > Len(Name) Then CompareFileName = True: Exit Function End If If Mid(Filter,fp) = "." Then ' special case: "." at end of filter CompareFileName = np > Len(Name): Exit Function End If Dim fc: fc = Mid(Filter,fp,1): fp = fp + 1 Select Case fc Case "*" CompareFileName = CompareFileName2(name,np,filter,fp) Exit Function Case "?" If np <= Len(Name) And Mid(Name,np,1) <> "." Then np = np + 1 Case Else If np > Len(Name) Then Exit Function Dim nc: nc = Mid(Name,np,1): np = np + 1 If Strcomp(fc,nc,vbTextCompare)<>0 Then Exit Function End Select Loop End Function Private Function CompareFileName2 (ByVal Name, ByVal np0, ByVal Filter, ByVal fp0) Dim fp: fp = fp0 Dim fc2 Do ' skip over "*" and "?" characters in filter If fp > Len(Filter) Then CompareFileName2 = True: Exit Function fc2 = Mid(Filter,fp,1): fp = fp + 1 If fc2 <> "*" And fc2 <> "?" Then Exit Do Loop If fc2 = "." Then If Mid(Filter,fp) = "*" Then ' special case: ".*" at end of filter CompareFileName2 = True: Exit Function End If If fp > Len(Filter) Then ' special case: "." at end of filter CompareFileName2 = InStr(np0,Name,".") = 0: Exit Function End If End If Dim np For np = np0 To Len(Name) Dim nc: nc = Mid(Name,np,1) If StrComp(fc2,nc,vbTextCompare)=0 Then If CompareFileName(Mid(Name,np+1),Mid(Filter,fp)) Then CompareFileName2 = True: Exit Function End If End If Next CompareFileName2 = False End Function Wscript.Quit |
Scritto da Raffaele Chiatto
Sono Raffaele Chiatto, un appassionato di informatica a 360°…
Mi sono avvicinato al mondo dell’informatica nel lontano 1996 con Windows 95 e da allora non ho più smesso di dedicarmi allo studio ed approfondimento di questo settore.
Laureato in Ingegneria Informatica nel 2009, lavoro nel campo dell’IT dal lontano 2001.
0 commenti