Nguyen Anh Dung
Board Regular
- Joined
- Feb 28, 2020
- Messages
- 180
- Office Version
- 2016
- Platform
- Windows
help edit code when run use mouse select folder not input directory folder as below:
Const strSOURCE_DIR = "d:\Image_SoNha\"
Const strTARGET_DIR = "d:\Image_SoNha\"
Const strSOURCE_DIR = "d:\Image_SoNha\"
Const strTARGET_DIR = "d:\Image_SoNha\"
Code:
Public Sub MoveImages()
Const strSOURCE_DIR = "d:\Image_Goc\"
Const strTARGET_DIR = "d:\Image_SoNha\"
Dim strSourcePath As String
Dim strTargetPath As String
Dim strSubfolder As String
Dim strFilename As String
Dim strMessage As String
Dim strErrors As String
Dim lngCounter As Long
On Error GoTo ErrHandler
strFilename = Dir(strSOURCE_DIR & "*.jpg")
Do While strFilename <> ""
strSourcePath = strSOURCE_DIR & strFilename
strSubfolder = strTARGET_DIR & "20200914_13_" & Mid(strFilename, 2, 3) & "_GoVap_D_01" 'D: Duong, H: Hem, 01: Di,02 Ve: tu sua
strTargetPath = strSubfolder & "\" & strFilename
' tao folder neu k ton tai
On Error Resume Next
MkDir strSubfolder
If Err.Number <> 0 Then Err.Clear
' cat qua thu muc moi
Name strSourcePath As strTargetPath
' If an error occurred, log it to error list
If Err.Number <> 0 Then
If strErrors <> "" Then strErrors = strErrors & ", "
strErrors = strErrors & strFilename
Else
lngCounter = lngCounter + 1
End If
' Move onto next jpg file
On Error GoTo ErrHandler
strFilename = Dir()
Loop
' Notify user of results, including any errors
strMessage = "Transfer of " & lngCounter & " files was completed."
If strErrors <> "" Then
strMessage = strMessage & vbCrLf & vbCrLf
strMessage = strMessage & "These files were unsuccessful:"
strMessage = strMessage & vbCrLf & strErrors
End If
MsgBox strMessage, vbInformation
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
End Sub