Results 1 to 3 of 3
2014-04-20, 01:20 #1
- Join Date
- Apr 2014
- Thanked 0 Times in 0 Posts
folder creation and moving pictures into that newly created folder at different location
Hello friends, I have two queries,
1. issue explanation- Pls check the attachment file "folder creation and fotos copied into the newly created folder at the specified folder,.. "
2. issue explanation: Pls refer the spreadsheet file "search & open that created folder from spreadsheet cell value linked thru hyperlink"
Issue Summary: when click it need to make a new folder on different location (d:\db) and then copying of photos into that created folder from photos source location (c:\fotos folder) to the destination of newly created folder (d:\db) from the cell value (eg: C4 as 9224) of spreadsheet. and also, i'm looking for the coding of cell value linked to that newly created folder as a hyperlink to open whenever we want to check the folder files...
Pls check the attachment files for issue clarity... Thanks in advance for your time and effort for reading...
I think this is the extreme usage of excel, but I hope from our excel gurus to solve this type of scenario…
Any help will be highly appreciated in this regard….
I tried some coding here, but it is not working... pls look into the codes as below: Folder creation with cell value: this is a working code, pls check this code, if need modification, pls do it. Thanks Code: Sub MakeFolders() Dim FldrName As String On Error Resume Next For i = 1 To 10 FldrName = ActiveCell.Value MkDir "C:\Make folder-test\" & FldrName Next i MsgBox "folder created, Done!!!!" End Sub Copying the images from the source to destination code: It is not working, pls look into the code, where it is wrong.. tried from file copy command to copy from source to destination, but unable … Sub CopyFileAddDate() Dim SrceFile1, SrceFile2 Dim copyingfname As String On Error Resume Next For i = 1 To 10 SrceFile1 = "C:\Users\new browsing\Desktop\My phot\Images\copyingfname" & ".jpg" DestFile1 = "C:\Make folder-test\copyingfname" & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".jpg" FileCopy SrceFile1, DestFile1 Next i End Sub Hyperlink code: Public Sub openHyperlink_ActiveCellValue_LOOP() Dim fldr As Folder Dim AA As Object, fpath1 As String fpath1 = "C:\Make folder-test\AA" AA = ActiveCell & fldr On Error GoTo 1 ActiveWorkbook.FollowHyperlink ActiveWorkbook.Path & _ "\fpath1", NewWindow:=True Exit Sub 1: MsgBox Err.Description End Sub OR The first part in this code is to invoke the system32 files to open folder: from the location: %SystemRoot%\system32\SHELL32.dll Private Declare Function SetCurrentDirectoryA Lib _ "kernel32" (ByVal lpPathName As String) As Long Sub ChDirNet(szPath As String) Dim lReturn As Long lReturn = SetCurrentDirectoryA(szPath) If lReturn = 0 Then Err.Raise vbObjectError + 1, "Error setting path." End Sub Public Sub CreateHyperlink_ActiveCellValue_LOOP() On Error GoTo Whoops OriginalCalculationMode = Application.Calculation Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Dim foldername As String foldername = ActiveCell.Value Set Getfolder = CreateObject("Scripting.FileSystemObject.GetFolder") OpenFolder = ("C:\Users\new browsing\Documents\foldername") Application.ScreenUpdating = False Sheets("EPR Tracker").Activate Do While Not IsEmpty(ActiveCell) If Err.Number <> 0 Then Err.Clear ActiveSheet.Hyperlinks.Add _ Anchor:=Selection, _ Address:=ActiveCell.Value, SubAddress:=OpenFolder, _ TextToDisplay:=ActiveCell.Value End If foldername = ActiveCell.Value & Folder.Open If IsError(Dir(OpenFolder & foldername)) = 1004 Then Err.Clear End If If FileSystemObject.FolderExists = True Then Folder.Name Open:=OpenFolder & foldername End If Loop ActiveCell.Offset(1, 0).Select ActiveWorkbook.Save Exit Sub Whoops: Application.Calculation = OriginalCalculationMode Application.ScreenUpdating = True End Sub ----------------------
2014-04-21, 08:34 #2
- Join Date
- Aug 2010
- Pa, USA
- Thanked 621 Times in 566 Posts
There were too many problems with your posted code so better to start from scratch. The following code should do what you want to do.
It will take the value of the active cell to create and name a new sub folder under C:\db\. It will then copy all .jpg files from your source folders C:\fotos folder\ to the new folder and rename them by inserting the date and time to the name. Lastly, it will make the cell value a hyperlink to open the new folder created.
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 FileCopy SourcePath & Filename, DestinationPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "_" & Filename Filename = Dir Loop '-------------------------------------------- 'ADD HYPERLINK ActiveSheet.Hyperlinks.Add ActiveCell, DestinationPath End Sub
The Following User Says Thank You to Maudibe For This Useful Post:
2014-04-22, 05:31 #3
- Join Date
- Apr 2014
- Thanked 0 Times in 0 Posts
Muaaaa!!!!!You are excellent, you are amazing, you are mind blowing....
I admit I make mistakes because there are guides like you to correct me....
God bless you with lots of happiness and health!!!! I have no words to thank you!!!!
Sir, you done it so neatly, effeciently, and precise that I can tell you are an expert in this excel programming...
I needed completely to move the pictures from the folder or delete the pictures from that picture folder after being copied into destination... because there would be another set of pictures to be loaded from scanner into that same folder directory for another PR no.s..... and then another PR.no.s... so on...
could you tell me one line code to delete that pictures after pictures being copied..
Thanks once again....