Hello,
I'm facing one issue with my vbscript. In summary this script is copying folders from one location to another and then it's removing source object (I had permission issuest when tried to move folders).
The distribution of source folders is based on first piece of folder name, where every piece is separated by #.
It seems that everything is workin fine now, besides one more important thing.
After finishing copying process I need to add label fo the folder in new location. I tried some movements without changing attributes but as previously said - no luck.Here's my code. Maybe someone will be able to help me (there may be some trashes here, so skip them if you can ):
Option Explicit
Dim fso, objFSO, shell, log, sourcePath, destPath, fileSystemObject, folder, subFolder
Set fso = CreateObject("Scripting.FileSystemObject")
Set shell = CreateObject("WScript.Shell")
Set log = fso.CreateTextFile("F:\log.txt", True)
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objFSO = CreateObject("Scripting.FileSystemObject")
sourcePath = "F:\"
destPath = "Y:\"
'Iterate through all folders in the source directory
For Each folder In fso.GetFolder(sourcePath).SubFolders
Dim folderName, folderParts
folderName = folder.Name
folderParts = Split(folderName, "#")
'Check if folder name matches pattern
If UBound(folderParts) = 4 Then
Dim x1, destFolder
x1 = folderParts(0)
log.WriteLine("Processing folder: " & folderName)
'Check if matching folder exists on destination drive
Set destFolder = Nothing
For Each subFolder In fso.GetFolder(destPath).SubFolders
If StrComp(subFolder.Name, x1, vbTextCompare) = 0 Then
Set destFolder = subFolder
Exit For
End If
Next
'If matching folder found, copy folder and delete from source
If Not destFolder Is Nothing Then
log.WriteLine(" Found matching folder on destination: " & destFolder.Path)
Dim destFolderPath
destFolderPath = destFolder.Path & "\" & folderName
objFSO.CopyFolder folder.Path, destFolderPath, True
If Err.Number = 0 Then
log.WriteLine(" Successfully copied folder to destination.")
fso.DeleteFolder folder.Path
If Err.Number = 0 Then
log.WriteLine(" Successfully deleted folder from source.")
'Assign label to destination folder after it has been successfully copied
shell.Run "cmd /c Properties """ & destFolderPath & """ SETLABEL PostedonFBcc ADDLABEL", 0, True
Else
log.WriteLine(" Error deleting folder from source: " & Err.Description)
End If
Else
log.WriteLine(" Error copying folder to destination: " & Err.Description)
End If
Else
log.WriteLine(" No matching folder found on destination.")
End If
Else
log.WriteLine("Skipping folder: " & folderName & ". Does not match pattern.")
End If
Next
'Clean up and display summary
log.Close()
Set objFSO = Nothing
Set fso = Nothing
Set shell = Nothing
Set log = Nothing
Set fileSystemObject = Nothing
MsgBox "Script complete. See log.txt for details."
You need to run Opus commands via the Opus command object. See the default script you get when creating a new script button for examples. (Or most other scripts on the forum.)
This assumes you're running the script inside Opus.
If it has to run outside of Opus, you can use DOpusRT.exe /acmd ... to send commands to Opus from another process. More detail in the DOpusRT.exe docs.
OK,
I have changed the script and it looks like the follow:
Option Explicit
Function OnClick(ByRef ClickData)
Dim fso, objFSO, shell, log, sourcePath, destPath, fileSystemObject, folder, subFolder, cmd
Set fso = CreateObject("Scripting.FileSystemObject")
Set shell = CreateObject("WScript.Shell")
Set log = fso.CreateTextFile("F:\log.txt", True)
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objFSO = CreateObject("Scripting.FileSystemObject")
sourcePath = "F:\"
destPath = "Y:"
'Iterate through all folders in the source directory
For Each folder In fso.GetFolder(sourcePath).SubFolders
Dim folderName, folderParts
folderName = folder.Name
folderParts = Split(folderName, "#")
'Check if folder name matches pattern
If UBound(folderParts) = 4 Then
Dim x1, destFolder
x1 = folderParts(0)
log.WriteLine("Processing folder: " & folderName)
'Check if matching folder exists on destination drive
Set destFolder = Nothing
For Each subFolder In fso.GetFolder(destPath).SubFolders
If StrComp(subFolder.Name, x1, vbTextCompare) = 0 Then
Set destFolder = subFolder
Exit For
End If
Next
'If matching folder found, copy folder and delete from source
If Not destFolder Is Nothing Then
log.WriteLine(" Found matching folder on destination: " & destFolder.Path)
Dim destFolderPath
destFolderPath = destFolder.Path & "\" & folderName
objFSO.CopyFolder folder.Path, destFolderPath, True
If Err.Number = 0 Then
log.WriteLine(" Successfully copied folder to destination.")
fso.DeleteFolder folder.Path
If Err.Number = 0 Then
log.WriteLine(" Successfully deleted folder from source.")
'Add label to the folder
Set cmd = clickData.func.command
cmd.RunCommand "Properties SETLABEL=PostedonFBcc" & destFolderPath
log.WriteLine(" Successfully added label to folder: " & destFolderPath)
Else
log.WriteLine(" Error deleting folder from source: " & Err.Description)
End If
Else
log.WriteLine(" Error copying folder to destination: " & Err.Description)
End If
Else
log.WriteLine(" No matching folder found on destination.")
End If
Else
log.WriteLine("Skipping folder: " & folderName & ". Does not match pattern.")
End If
Next
'Clean up and display summary
log.Close()
Set objFSO = Nothing
Set fso = Nothing
Set shell = Nothing
Set log = Nothing
Set fileSystemObject = Nothing
DOpus.OutputString "Script complete. See log.txt for details."
End Function
Never the less it's still refusing to set label for destFolderPath.
Instead of that it is opening Properties window of file which is currently slected in source folder.
):
