Path = "Z:\Ebay\Suppliers Inventory\" & Fnumber & "\" & Fname & "\"
It works up to the last (& "\") then the Path will fail. My SKU is (XXX-000001) not sure if the dash is the problem and would be a pain to fix at this late date.
Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Path As String
Dim GetPath As String
Dim Filename As String
Dim GetFileName As String
Dim Fname As String
Dim Fnumber As String
Fnumber = Me.FolderNumber
Fname = [SKU]
Path = "Z:\Ebay\Suppliers Inventory\" & Fnumber & "\" & Fname & "\"
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.InitialFileName = Path
openDialog.AllowMultiSelect = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = False
If openDialog.Show Then
GetFileName = openDialog.SelectedItems(1)
Else
GetFileName = ""
End If
Forms![Items to List].ImageGroup.Form.PicText = GetFileName
Me.Image2 = GetFileName
Related
from the below mentioned VBA code i am able to move files from Source to destination, however after moving the files i need to change the folder name by date everyday, is there anyway we can move the files directly to the updated date folder, the pattern of the folder name/folder date is
01102022
02102022
03102022
the code i have is
Option Explicit
Sub MoveFilesTEST()
Const sFolderPath As String = "E:\Asianet2"
Const dFolderPath As String = "E:\Asianet3"
Const FilePattern As String = "*.*"
MoveFiles sFolderPath, dFolderPath, FilePattern
End Sub
Sub MoveFiles( _
ByVal SourceFolderPath As String, _
ByVal DestinationFolderPath As String, _
Optional ByVal FilePattern As String = "*.*")
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(SourceFolderPath) Then
MsgBox "The source folder path '" & SourceFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
If Not fso.FolderExists(DestinationFolderPath) Then
MsgBox "The destination folder path '" & DestinationFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim apSep As String: apSep = Application.PathSeparator
Dim sPath As String: sPath = SourceFolderPath
If Left(sPath, 1) <> apSep Then sPath = sPath & apSep
Dim sFolder As Object: Set sFolder = fso.GetFolder(sPath)
If sFolder.Files.Count = 0 Then
Exit Sub
End If
Dim dPath As String: dPath = DestinationFolderPath
If Left(dPath, 1) <> apSep Then dPath = dPath & apSep
Dim dFolder As Object: Set dFolder = fso.GetFolder(dPath)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sFile As Object
Dim dFilePath As String
Dim ErrNum As Long
Dim MovedCount As Long
Dim NotMovedCount As Long
For Each sFile In sFolder.Files
dFilePath = dPath & sFile.Name
If fso.FileExists(dFilePath) Then
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
Else
On Error Resume Next
fso.MoveFile sFile.Path, dFilePath
ErrNum = Err.Number
' e.g. 'Run-time error '70': Permission denied' e.g.
' when the file is open in Excel
On Error GoTo 0
If ErrNum = 0 Then
MovedCount = MovedCount + 1
Else
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
End If
End If
Next sFile
Dim Msg As String
End Sub
screenshot
Please, use the next code. It creates the folder (as ddmmyyyy) in "dFolderPath" and moves all files existing in "sFolderPath":
Sub moveAllFilesInDateFolder()
Dim DateFold As String, fileName As String
Const sFolderPath As String = "E:\Asianet2"
Const dFolderPath As String = "E:\Asianet3"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy")' create the folder if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
If fileName = "" Then MsgBox "No any file in " & sFolderPath & "...": Exit Sub
Do While fileName <> ""
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
fileName = Dir
Loop
End Sub
Please, send some feedback after testing it...
You probably would need previously checking if there are no files in "dateFold", to avoid asking for overwriting in case of running the code twice (in the same day, by mistake)...
I have a directory that has 1000's of files. The filename string goes like: ManagerName_EmployeeName_First Assessment.xlsx
but I have a specific type of grouping I need to execute so that I have folders go by ManagerName > Employee Name and then the 5 types of Assessments in the employees folder.
How would I edit this to identify the first _ in the filename (ManagerName) and then make a folder by that ManagerName and then make a subfolder by EmployeeName and then house all five files under that employee in the employee subfolder?
I know you'd need to use a Left(fileName, InStrRev(fileName, "_") > 1) type function to identify the first text string to the left of the first _ but how would I go and create a second subfolder based on the employee under that manager?
Here's a shell of the code I was thinking:
Option Explicit
Sub MoveFiles()
Dim objFSO As Object
Dim objMyFolder As Object
Dim objMyFile As Object
Dim strSourceFolder As String
Dim strDestFolder As String
Application.ScreenUpdating = False
strSourceFolder = "C:\Users\CIB\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objMyFolder = objFSO.GetFolder(strSourceFolder)
For Each objMyFile In objMyFolder.Files
Do While objMyFile <> ""
strDestFolder = Left(objMyFile.Name, InStrRev(objMyFile, "_") - 1)
If Len(Dir(strDestFolder, vbDirectory)) = 0 Then
MkDir strDestFolder
End If
FileCopy strSourceFolder & "\" & objMyFile.Name, strDestFolder & "\" & objMyFile.Name
Kill strSourceFolder & "\" & objMyFile.Name
Loop
Next objMyFile
Set objFSO = Nothing
Set objMyFolder = Nothing
Application.ScreenUpdating = True
End Sub
I've changed your code accordingly to TimWiliams suggestions:
Option Explicit
Sub MoveFiles()
Dim objFSO As Object
Dim objMyFolder As Object
Dim objMyFile As Object
Dim strSourceFolder As String
Dim strDestFolder As String
Dim parts() As String
Dim i As Integer
Application.ScreenUpdating = False
strSourceFolder = "C:\Users\CIB\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objMyFolder = objFSO.GetFolder(strSourceFolder)
For Each objMyFile In objMyFolder.Files
If objMyFile Is Nothing Then GoTo SkipNext
parts = Split(objMyFile.Name, "_")
strDestFolder = strSourceFolder
For i = LBound(parts) To UBound(parts) - 1
strDestFolder = strDestFolder & parts(i) & "\"
'if path does not exists, create it
If Not objFSO.FolderExists(strDestFolder) Then objFSO.CreateFolder strDestFolder
FileCopy strSourceFolder & "\" & objMyFile.Name, strDestFolder & "\" & objMyFile.Name
Kill strSourceFolder & "\" & objMyFile.Name
strDestFolder = ""
SkipNext:
Next objMyFile
Set objFSO = Nothing
Set objMyFolder = Nothing
Application.ScreenUpdating = True
End Sub
Have a requirement to store a file in mydocuments. Save location has to be VDI or laptop independent.
I am able to successfully save the file, in the location I want. But with the same file name and location, I am unable to open it.
The path and the filename for workbooks.open is coming like this, when I am testing it thru VDI. Bit strange, I not able to open the workbook using the path I used to save it.
"\xxx.yyy.CO.NZ\PaleeS.home$\InsuranceAdvisory\Excel\DT_test delete_rectangle 1_04.May.17.xlsm"
Dim strFilename As String
Dim Client1 As Range
Dim Client2 As Range
Dim CurrentDate As String
Dim FilePrefix As String
Dim strDir As String
Dim StrDirSub As String
Dim Savedflie As String
Dim CurrentFolderpath As String
Dim CurrentFilename As String
CurrentFolderpath = Application.ActiveWorkbook.Path
CurrentFilename = Application.ActiveWorkbook.Path & "\" & Application.ActiveWorkbook.FullName
strDir = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & Application.PathSeparator & "\InsuranceAdvisory"
StrDirSub = strDir & "\Excel"
If Dir(strDir, vbDirectory) = "" Then
MkDir strDir
End If
Select Case Dir(StrDirSub, vbDirectory)
Case ""
MkDir StrDirSub
End Select
FilePrefix = "\DT_"
Set Client1 = Range("Client1")
Set Client2 = Range("Client2")
CurrentDate = Format(Date, "dd.mmm.yy")
strFilename = FilePrefix & Client1.Value & "_" & Client2.Value & "_" & CurrentDate
ActiveWorkbook.Save
ActiveWorkbook.SaveCopyAs StrDirSub & strFilename & ".xlsm"
Savedflie = StrDirSub & strFilename & ".xlsm"
Application.Workbooks.Open (Savedflie)
I have written the below script which creates a folder in a given location if it doesn't exist which is named after a cell in the workbook.
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
Dim sFileType As String
Dim sSourcePath As String
Dim Destination As String
Set fso = CreateObject("scripting.filesystemobject")
sSourcePath = "\\INSURANCE\IT\FileData\Computers\DIPS\"
fldrname = Worksheets("Applications").Range("A2").Value
fldrpath = "\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
End If
I'm now trying to copy all .xlsm files in sSourcePath to the newly created location fldrpath & \ fldrname yet all attempts fail. I'm still fairly new to VBA so any help would be appreciated.
I have heard of .copyfile but i'm not sure how to utilise this in this example.
Thank you in advance.
I do this without filesystemobject.
Sub copyfiles()
Dim source_file As String, dest_file As String
Dim source_path As String, dest_path As String
Dim i As Long, file_array As Variant
source_path = "\\INSURANCE\IT\FileData\Computers\DIPS"
dest_path = "\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive"
source_file = Dir(source_path & "\" & "*.xlsm")
Do Until source_file = ""
If Not IsArray(file_array) Then
ReDim file_array(0) As Variant
Else
ReDim Preserve file_array(UBound(file_array) + 1) As Variant
End If
file_array(UBound(file_array)) = source_file
source_file = Dir
Loop
'If new folder is not existed, create it.
If Dir(dest_path, 16) = "" Then MkDir dest_path '16=vbDirectory
For i = LBound(file_array) To UBound(file_array)
FileCopy source_path & "\" & file_array(i), dest_path & "\" & file_array(i)
Next i
End Sub
My take on that
Sub copyFiles()
Dim fldrname As String, fldrpath As String, sFileType As String
Dim sSourcePath As String, Destination As String
Dim fso As Object, fFolder As Object, fFile As Object
Set fso = CreateObject("scripting.filesystemobject")
sSourcePath = "\\SourcePath" '"\\INSURANCE\IT\FileData\Computers\DIPS\"
fldrname = "data\" 'Worksheets("Applications").Range("A2").Value
fldrpath = "\\SourcePath\Archive\" & fldrname '"\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
Set fFolder = fso.GetFolder(sSourcePath)
For Each fFile In fFolder.Files
'If Not (fso.FileExists(fldrpath & fFile.Name)) Then fFile.Copy fldrpath, Overwritefiles:=False
fFile.Copy fldrpath, Overwritefiles:=True
Next fFile
End Sub
Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question does not appear to be about a specific programming problem, a software algorithm, or software tools primarily used by programmers. If you believe the question would be on-topic on another Stack Exchange site, you can leave a comment to explain where the question may be able to be answered.
Closed 7 years ago.
Improve this question
I am curious to know how to move emails from a specific subfolder to my hard drive. Basically, my inbox has about 20 subfolders. I want to be able to move all the emails from subfolder1 to my hard drive.
Is there a macro to specifically go to that folder and move all the emails onto my hard drive? Granted I do want to keep all the emails in .msg rather than being a .txt file.
I bielive you can develop a VBA macro or add-in to get the job done. See Getting Started with VBA in Outlook 2010 to get started.
The SaveAs method of the MailItem class saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used. The file type to save can be one of the following OlSaveAsType constants: olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode. For example:
Sub SaveAsMSG()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
This should allow you to select outlook folder and hard drive folder, All emails in that folder and all sub folders will be saved to your HD
Option Explicit
Sub SaveMsgToFolders()
Dim i, j, n As Long
Dim sSubject As String
Dim sName As String
Dim sFile As String
Dim sReceived As String
Dim sPath As String
Dim sFolder As String
Dim sFolderPath As String
Dim SaveFolder As String
Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim olApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim olmItem As MailItem
Dim FSO, ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set olApp = Outlook.Application
Set iNameSpace = olApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder ' // Chose Outlook Folder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
sPath = BrowseForFolder
If sPath = "" Then
GoTo ExitSub:
End If
If Not Right(sPath, 1) = "\" Then
sPath = sPath & "\"
End If
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
sFolder = StripIllegalChar(Folders(i))
n = InStr(3, sFolder, "\") + 1
sFolder = Mid(sFolder, n, 256)
sFolderPath = sPath & sFolder & "\"
SaveFolder = Left(sFolderPath, Len(sFolderPath) - 1) & "\"
If Not FSO.FolderExists(sFolderPath) Then
FSO.CreateFolder (sFolderPath)
End If
Set SubFolder = olApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set olmItem = SubFolder.Items(j)
sReceived = ArrangedDate(olmItem.ReceivedTime)
sSubject = olmItem.Subject
sName = StripIllegalChar(sSubject)
sFile = SaveFolder & sReceived & "_" & sName & ".msg"
sFile = Left(sFile, 256)
olmItem.SaveAs sFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Function ArrangedDate(sDateInput)
Dim sFullDate As String
Dim sFullTime As String
Dim sAMPM As String
Dim sTime As String
Dim sYear As String
Dim sMonthDay As String
Dim sMonth As String
Dim sDay As String
Dim sDate As String
Dim sDateTime As String
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
If Not Left(sDateInput, 2) = "10" And _
Not Left(sDateInput, 2) = "11" And _
Not Left(sDateInput, 2) = "12" Then
sDateInput = "0" & sDateInput
End If
sFullDate = Left(sDateInput, 10)
If Right(sFullDate, 1) = " " Then
sFullDate = Left(sDateInput, 9)
End If
sFullTime = Replace(sDateInput, sFullDate & " ", "")
If Len(sFullTime) = 10 Then
sFullTime = "0" & sFullTime
End If
sAMPM = Right(sFullTime, 2)
sTime = sAMPM & "-" & Left(sFullTime, 8)
sYear = Right(sFullDate, 4)
sMonthDay = Replace(sFullDate, "/" & sYear, "")
sMonth = Left(sMonthDay, 2)
sDay = Right(sMonthDay, Len(sMonthDay) - 3)
If Len(sDay) = 1 Then
sDay = "0" & sDay
End If
sDate = sYear & "-" & sMonth & "-" & sDay
sDateTime = sDate & "_" & sTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(sDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function