Results 1 to 6 of 6
  1. #1
    New Lounger
    Join Date
    Apr 2014
    Posts
    6
    Thanks
    1
    Thanked 0 Times in 0 Posts

    create new folder at one location and copy photos in that folder from other location

    Hi Friends,

    I'm trying to create a new folder and copy all the files present in photos folder to the newly created folder. I will be grateful to you if you can help me with this issue. Hope the issue is understood. It can create the folder but unable to copy pic files into that folder

    Pls check the Demo sheet in attachment.

    I tried some coding here, but it is not working... pls look into the code as below:

    Code:
    Option Explicit
    Sub makefolders()
    Dim FldrName as String
    Dim i As String
    On Error Resume Next
    For i=1 to 10
    FldrName = ActiveCell.Value
    MkDir “I:\FOTO(s) Folder-PR records\” & FldrName
    Next i
    Call Copy_pic_files_to_fotofoldr
    MsgBox “folder created, Done & All Pic/Photos copied!!!”
    End sub
    
    Sub Copy_pic_files_to_fotofoldr()
    'This example copy all files and subfolders from FromPath to ToPath.
    'Note: If ToPath already exist it will overwrite existing files in this folder
    'if ToPath not exist it will be made for you.
        Dim FSO As Object
        Dim FromPath As String
        Dim ToPath As String
        Dim aa As String
       
        FromPath = "C:\Users\new browsing\Desktop\My phot\Images\Folder-0001\"  '<< Change
        ToPath = "C:\Make folder-test\ FldrName "     '<< Change
    
        'If you want to create a backup of your folder every time you run this macro
        'you can create a unique folder with a Date/Time stamp.
        ToPath = " I:\fotos-backup\" & Format(Now, "yyyy-mm-dd h-mm-ss")
    
        If Right(FromPath, 1) = "\" Then
            FromPath = Left(FromPath, Len(FromPath) - 1)
        End If
    
        If Right(ToPath, 1) = "\" Then
            ToPath = Left(ToPath, Len(ToPath) - 1)
        End If
    
        Set FSO = CreateObject("scripting.filesystemobject")
    
        If FSO.FolderExists(FromPath) = False Then
            MsgBox FromPath & " doesn't exist"
            Exit Sub
        End If
    
        FSO.CopyFolder Source:=FromPath, Destination:=ToPath
        MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
    
    End Sub
    Attached Files Attached Files

  2. #2
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,629
    Thanks
    114
    Thanked 645 Times in 589 Posts
    could you tell me one line code to delete that pictures after pictures being copied.
    Meer,

    From:
    To answer your question from your previous thread, you will need to change one line of code in the code I gave you:

    FileCopy SourcePath & Filename, DestinationPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "_" & Filename

    To:

    Name SourcePath & Filename As DestinationPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "_" & Filename

    This will remove the .jpg files from your source folder when they are placed in your target directory. The entire code is:

    Code:
    Sub MakeFolders()
    On Error Resume Next
    '--------------------------------------------
    'DIM VARIABLES
    Dim FldrName As String
    Dim SourcePath As String
    Dim DestinationPath As String
    '--------------------------------------------
    'SET SOURCE AND DESTINATION PATHS
    SourcePath = "C:\fotos folder\"
    FldrName = ActiveCell.Value
    MkDir "D:\db\" & FldrName & "\"
    DestinationPath = "D:\db\" & FldrName & "\"
    '--------------------------------------------
    'COPY FILES FROM SOURCE TO DESTINATION
    Filename = Dir(SourcePath & "*.jpg")
    Do While Len(Filename) > 0
        Name SourcePath & Filename As DestinationPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "_" & Filename
        Filename = Dir
    Loop
    '--------------------------------------------
    'ADD HYPERLINK
    ActiveSheet.Hyperlinks.Add ActiveCell, DestinationPath
    End Sub
    Last edited by Maudibe; 2014-04-22 at 09:25.

  3. #3
    New Lounger
    Join Date
    Apr 2014
    Posts
    6
    Thanks
    1
    Thanked 0 Times in 0 Posts
    Thank you sir, once again.God bless you...

    could we make the folders creation process unique in the directory, i.e, no duplication of folders in that directory..if the folder of that name already exists, it should exit the sub (no overwriting in the directory with the same name)..

  4. #4
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,629
    Thanks
    114
    Thanked 645 Times in 589 Posts
    Meer

    The 3 added lines will alert you that the folder already exists then exit the sub.

    HTH,
    Maud

    Code:
    Sub MakeFolders()
    On Error GoTo ErrorHandler  'NEW LINE ADDED
    '--------------------------------------------
    'DIM VARIABLES
    Dim FldrName As String
    Dim SourcePath As String
    Dim DestinationPath As String
    '--------------------------------------------
    'SET SOURCE AND DESTINATION PATHS
    SourcePath = "C:\fotos folder\"
    FldrName = ActiveCell.Value
    MkDir "D:\db\" & FldrName & "\"
    DestinationPath = "D:\db\" & FldrName & "\"
    '--------------------------------------------
    'COPY FILES FROM SOURCE TO DESTINATION
    Filename = Dir(SourcePath & "*.jpg")
    Do While Len(Filename) > 0
        Name SourcePath & Filename As DestinationPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "_" & Filename
        Filename = Dir
    Loop
    '--------------------------------------------
    'ADD HYPERLINKActiveSheet.Hyperlinks.Add ActiveCell, DestinationPath
    Exit Sub
    ErrorHandler:  'NEWLINE ADDED
    MsgBox "A folder with that name already exists."  'NEW LINE ADDED
    End Sub

  5. #5
    New Lounger
    Join Date
    Apr 2014
    Posts
    6
    Thanks
    1
    Thanked 0 Times in 0 Posts
    Hi Sir,

    I test run your updated code, but it is not running completely, though it creates the folder but unable to copy the pics into the folder and the hyperlink shows active but unable to open it... error as: cannot open the specified file.. it is not verifying the same record no. before creating.. Don't know, may be I have done some thing wrong in your coding..

    Pls check the demo file in attachments..

    I modified your code little, but it was working... pls see as below:

    Code:

    Code:
    Sub MakeFolders()
    On Error Resume Next
        '--------------------------------------------
    'DIM VARIABLES
    Dim FldrName As String
    Dim SourcePath As String
    Dim DestinationPath As String
    Dim Filename As String
        ' --------------------------------------------
    'SET SOURCE AND DESTINATION PATHS
    SourcePath = "C:\Users\new browsing\Pictures\Mypics\"
    FldrName = ActiveCell.Value
    MkDir "C:\foto(s) PR records\" & FldrName & "\"
    DestinationPath = "C:\foto(s) PR records\" & FldrName & "\"
    ' -------------------------------------------------
    'COPY FILES FROM SOURCE TO DESTINATION
    Filename = Dir(SourcePath & "*.jpg")
    Do While Len(Filename) > 0
    Name SourcePath & Filename As DestinationPath = "C:\foto(s) PR records\" & FldrName & "\" & "_" & Filename
    Filename = Dir
    Loop
    '----------------------------------------------
    'ADD HYPERLINK
    ActiveSheet.Hyperlinks.Add ActiveCell, DestinationPath = "C:\foto(s) PR records\" & FldrName & "\"
    MsgBox "folder created, Done & All Pic/Photos copied & moved!!!"
    Exit Sub
    
    ErrorHandler: 'NEWLINE ADDED
    MsgBox "A folder with that name already exists"   'NEW LINE ADDED
    End Sub
    Attached Files Attached Files
    Last edited by meer_ali; 2014-04-23 at 06:27.

  6. #6
    New Lounger
    Join Date
    Apr 2014
    Posts
    6
    Thanks
    1
    Thanked 0 Times in 0 Posts
    Hi sir,

    Thank you for helping me with your code that solved my problems.. Anyway, i use your previous code that is working good..

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •