Вопрос детально описан на картинке:
Я использую скрипт для чуть похожих действий, но не с папками, а с файлами.
К сожалению, у меня не хватает знаний для того, чтобы переделать его под решение описанной выше задачи.
Помогите, пожалуйста! Буду очень признателен!
----------------------------------------------------------------------------------
Option Compare Database
Option Explicit
'Access constants
Private Const A_INCOMING_ORDERS = "a_Incoming_Orders"
Private Const q_20_Wait = "q_20_Wait"
Private Const q_20_ACT = "q_20_ACT"
Private Const q_All = "q_All"
Private Const order_int_ID = "order_int_ID"
Private Const order_stage = "order_stage"
'Folders
Private Const FLD_DOWNLOADS = "d:\==Orders1290\10-1-Downloads\"
Private Const FLD_WAIT = "d:\==Orders1290\10-2-0-Wait\"
Private Const FLD_WAIT_90 = "d:\==Orders1290\10-2-1-Wait_PSD-90\"
Private Const FLD_PROCESS_PSD = "d:\==Orders1290\10-3-0-ProcessPSD"
Private Const FLD_PROCESS_ACT = "d:\==Orders1290\10-3-1-ProcessAction"
Private Const FLD_CHECK = "d:\==Orders1290\10-4-0-Check"
Private Const FLD_READY = "d:\==Orders1290\10-5-0-Ready"
----------------------------------------------------------
Private Sub Ctl10_20___10_30_Click()
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get all files in FLD_WAIT
Dim fileList As Object
Set fileList = CreateObject("Scripting.Dictionary")
Dim oFile As Object, baseName As String
For Each oFile In FSO.GetFolder(FLD_WAIT).Files
baseName = FSO.GetBaseName(oFile.Name)
If fileList.Exists(baseName) Then
MsgBox _
"Existing: " & fileList.Item(baseName) & vbLf & vbLf & _
"Duplicate: " & oFile.Path, vbExclamation, _
"Duplicate Found - while collecting file names in { FLD_WAIT }."
Else
fileList.Add baseName, oFile.Path
End If
Next
'Open Recordset
Dim rs As Recordset
On Error Resume Next
Set rs = CurrentDb.OpenRecordset(q_20_ACT)
If (Not Err.Number = 0) Then MsgBox Err.Description, vbCritical, "Recordset: " & q_20_ACT: Exit Sub
If (rs.BOF And Not rs.EOF) Then: MsgBox "No data in recordset!", vbCritical, "Recordset: " & q_20_ACT: Exit Sub
On Error GoTo 0
'Move files in query matching order_int_ID
Dim idName, dFolder As String, cont As Integer
While (Not rs.EOF)
idName = rs.Fields(order_int_ID).Value
If TypeName(idName) = "String" Then
If fileList.Exists(idName) Then
dFolder = FLD_PROCESS_PSD & "\" & idName
If FSO.FolderExists(dFolder) Then
cont = MsgBox( _
"{ FLD_PROCESS_PSD } already has a folder in it matching an { ORDER_INT_ID } of: " & idName & vbLf & vbLf & "Skip & continue with the next file?", vbOKCancel + vbExclamation, _
"While creating folders for { ORDER_INT_ID } files")
If cont = vbCancel Then Exit Sub
Else
FSO.CreateFolder dFolder
FSO.MoveFile fileList.Item(idName), dFolder & "\"
rs.Edit: rs.Fields(order_stage) = "3_in_ACTION": rs.Update
End If
Else
cont = MsgBox( _
"No files found in { FLD_WAIT } that match an { ORDER_INT_ID } of: " & idName & vbLf & vbLf & "Skip & continue with the next file?", vbOKCancel + vbExclamation, _
"While moving { ORDER_INT_ID } files")
If cont = vbCancel Then Exit Sub
End If
End If
rs.MoveNext
Wend
rs.Close
End Sub
