Programme permettant de sauvegarder toutes les pièces jointes d'un répertoire (et/ou de tous ses sous-répertoires) avec des critères sur les pièces jointes ou les expéditeurs etc...
Un rapport en HTML est généré à la fin, ce dernier est très facilement exportable sous excel (copier-coller)
Attention, 3 controls doivent être ajoutés
Microsoft Date and Time Picker Control 6.0
Microsoft ProgressBar Control 6.0
Microsoft TreeView Control 6.0
Vous trouver l'objet manquant à cette adresse
http://support.microsoft.com/kb/297381
Dans le zip, vous avez ces 2 fichiers
Save_Attachement.frm
Save_Attachement.frx
Et n'oubliez par le petit Merci.basic qui fait toujours plaisir
Source / Exemple :
'####################################################################
'# Author : Xavier Bourdeau (xav.bourdeau@free.fr #
'# Program : Attachement Saver Version : 4.5.2 #
'# #
'# This VBA Macros will extract attachements from an outlook folder #
'# (or recursive, since Version 3) & with criteria selection #
'# Please share it, but don't modifiy it without notifying me and #
'# sending me the new version. #
'# #
'# Thanks to David A. for idea and inspiration #
'# #
'####################################################################
'You'll need those additional controls
'if you are missing one of them, you will need MSCOMCT2.OCX in C:\Windows\System32 folder
'You can download MSCOMCT2.OCX at http://support.microsoft.com/kb/297381
'
'Microsoft Date and Time Picker Control 6.0
'Microsoft ProgressBar Control 6.0
'Microsoft TreeView Control 6.0
'
'You may need to restart Outlook when controls are just added
'
Public ProgressBarWidth As Integer
Private Sub Bt_About_Click()
'Please do not edit this line, for the glory of I
MsgBox "Attachement Saver" & vbCrLf & "This program is provided by Xavier Bourdeau" & vbCrLf & "Please send me bugs, comment and donation :o)", vbInformation, "About this little program"
End Sub
Private Sub Bt_Cancel_Click()
'Good bye
Unload Me
End Sub
Private Sub Bt_Export_Click()
Dim Temp As Variant
Temp = BrowseForFolder
If Temp = False Then Exit Sub
TextBox_Dir = Temp
End Sub
Public Function FileOrFolderExists(FullPathFile As String) As Boolean
'This function return TRUE if the file or folder exists, and return FALSE if it does not exist
On Error GoTo argh 'ok ok, it's not beautifull, but work so fine, because DIR function has a lot of limitations, onerror manage all the others
If Not Dir(FullPathFile, vbDirectory) = vbNullString Then FileOrFolderExists = True
Exit Function
argh:
FileOrFolderExists = False
On Error GoTo 0
End Function
Private Sub CB_FileType_Change()
TB_FileType = ""
If CB_FileType = "Office docs" Then TB_FileType = "*.xls;*.xlsx;*.doc;*.docx;*.pps;*.ppt;*.ppsx;*.pptx"
If CB_FileType = "Excel" Then TB_FileType = "*.xls;*.xlsx"
If CB_FileType = "Word" Then TB_FileType = "*.doc;*.docx"
If CB_FileType = "PowerPoint" Then TB_FileType = "*.pps;*.ppt;*.ppsx;*.pptx"
If CB_FileType = "PDF" Then TB_FileType = "*.pdf"
If CB_FileType = "Pictures" Then TB_FileType = "*.jpg;*.jpeg;*.bmp;*.gif;*.png"
If CB_FileType = "Text" Then TB_FileType = "*.txt;*.csv"
If CB_FileType = "No Type" Then TB_FileType = "*[blank]"
If CB_FileType = "Archives" Then TB_FileType = "*.zip;*.rar;*.arj;*.tar.gz;*.tgz;*.cpio"
End Sub
Private Sub CB_Send_Change()
If CB_Send = "Between" Then
Label_To.Visible = True
Date_2.Visible = True
Else
Label_To.Visible = False
Date_2.Visible = False
End If
Me.Repaint
End Sub
Private Sub Chk_Send_Click()
If CB_Send.Text = "" Then CB_Send.ListIndex = 0
End Sub
Private Sub Chk_SenderToCC_Click()
If CB_SenderToCC = "" Then CB_SenderToCC.ListIndex = 0
End Sub
Private Sub Chk_Subject_Click()
If CB_Subject.Text = "" Then CB_Subject.ListIndex = 0
End Sub
Private Sub ChkSenderToCC_Click()
If CB_SenderToCC.Text = "" Then CB_SenderToCC.ListIndex = 0
End Sub
Private Sub CommandButton1_Click()
Dim SelItem As Integer
Dim FolderName(200) As String
Dim Outlook_Archive As String
Dim Outlook_Path As String
Dim i, j As Integer
Dim Delete_Param As Integer
If FileOrFolderExists(TextBox_Dir) = False Or TextBox_Dir = "" Then
MsgBox ("Destination folder does not exist or not set correctly")
Exit Sub
End If
'Just checking that Target Folder has a \ at the end, in case path is entered manually, otherwise WriteLine & file extration will crash
If Right(TextBox_Dir, 1) <> "\" Then
TextBox_Dir = TextBox_Dir & "\"
End If
If Opt_Nothing = True Then
Delete_Param = 0
End If
If Opt_Del_Att.Value = True Then
If MsgBox("Are you sure you want to delete the attachement, after the files are extraceted ???", vbOKCancel) = vbCancel Then Exit Sub
Delete_Param = 1
End If
If Opt_Del_Mail.Value = True Then
If MsgBox("Are you sure you want to delete the mail, after the files are extraceted ???", vbOKCancel) = vbCancel Then Exit Sub
Delete_Param = 2
End If
If tvw.SelectedItem = "Outlook" Then
MsgBox "Do not select Outlook"
Exit Sub
End If
If tvw.SelectedItem.Parent.Index < 2 Then
MsgBox "You must select a subfolder"
Exit Sub
End If
If Check_Recur = True Then
Att_Proc_Recur tvw, tvw.SelectedItem, TextBox_Dir, TextBox_LogFile, Delete_Param
MsgBox ("Export Completed" & vbCrLf & "Destination : " & TextBox_Dir & vbCrLf & "Log file : " & TextBox_Dir & TextBox_LogFile & vbCrLf & "Recursive Mode : folders & subfolders")
Else
SelItem = tvw.SelectedItem.Index
i = 1
While SelItem <> 1
FolderName(i) = tvw.Nodes.Item(SelItem)
i = i + 1
SelItem = tvw.Nodes(SelItem).Parent.Index
Wend
'Outlook root is Item (0)
'Outlook archive is supposed to be the Item -1 (1)
Outlook_Archive = FolderName(i - 1)
Outlook_Path = ""
'Other Folder & Subfoler are item - x (x > 1)
For j = i - 2 To 1 Step -1
Outlook_Path = Outlook_Path & FolderName(j) & "/"
Next
Outlook_Path = Left(Outlook_Path, Len(Outlook_Path) - 1) 'remove the last "\" or it will confuse the Split function in Att_Proc
'MsgBox (Outlook_Archive & vbCrLf & Outlook_Path & vbCrLf & TextBox_Dir & vbCrLf & TextBox_LogFile & vbCrLf & Delete_Param)
Att_Proc Outlook_Archive, Outlook_Path, TextBox_Dir, TextBox_LogFile, Delete_Param
MsgBox ("Export Completed" & vbCrLf & "Destination : " & TextBox_Dir & vbCrLf & "Log file : " & TextBox_Dir & TextBox_LogFile)
End If
End Sub
Private Sub Att_Proc(Outlook_Archive As String, Outlook_Path As String, Att_Path As String, Att_Log As String, Delete_Param As Integer)
Dim FinalName, FileNameLegal As String
Dim FinalNameCount As Integer
Dim Cpt As Integer
Dim i, j As Integer
Dim ProgressNum, PercentNum, PercentCount As Variant
Dim MyFolders, MyFolder As Variant
Dim FirstFileHeader As Boolean
Dim objSubject As String
Dim objSenderName As String
Dim objTo As String
Dim objCC As String
Dim objReceivedTime As Date
Set objOutlook = CreateObject("Outlook.Application")
Set objFolder = objOutlook.GetNamespace("MAPI").Folders(Outlook_Archive)
MyFolders = Split(Outlook_Path, "/", -1, 1)
For Each MyFolder In MyFolders
Set objFolder = objFolder.Folders(MyFolder)
Next
Cpt = 0 'Incremental number of attached files
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLog = objFSO.CreateTextFile(Att_Path & Att_Log)
objLog.WriteLine "<HTML><TITLE>Report of Saved Attachements</TITLE><BODY><table border=""1"" cellpadding=""5"" cellspacing=""5"" width=""100%""><tr><th>Date</th><th>Outlook Archive</th><th>Outlook Folders</th></tr><tr>"
objLog.WriteLine "<td>" & Now & "</td><td>" & Outlook_Archive & "</td><td>" & Outlook_Path & "</td></tr></table><br>"
Set objItems = objFolder.Items
If objItems.Count = 0 Then
objLog.WriteLine "<br><B>I did nothing : This outlook folder is empty</B><br>"
Exit Sub
End If
'Set status line for those who like excel
objLog.WriteLine "<table border=""1"" witdh=""100%"">" & _
"<tr>" & _
"<th>Sender</th>" & _
"<th>To</th>" & _
"<th>CC</th>" & _
"<th>Subject</th>" & _
"<th>Date</th>" & _
"<th>Attached File(s)</th>" & _
"</tr>"
PercentCount = 0 'init value in case of restart
ProgressBar.Min = 0
ProgressBar.Max = objItems.Count
ProgressBar.Value = 0
PercentNum = 100 / objItems.Count
For mailIndex = objItems.Count To 1 Step -1
'in order to get percentage, PercentCount is the progression index for each mail
'PercentLabel just add a % sign at the end
ProgressBar.Value = ProgressBar.Value + 1
PercentCount = PercentCount + PercentNum
PercentLabel = Int(PercentCount) & "%" 'int avoid decimal and make the percentage beautiful
Set objMailItem = objItems.Item(mailIndex)
On Error Resume Next
'those variables are used only to avoir any html crutial text write
'because sometime to & cc crash for meeting invitation mail
objTo = ""
objCC = ""
objSenderName = ""
objSubject = objMailItem.Subject
objReceivedTime = objMailItem.ReceivedTime
objSenderName = objMailItem.SenderName
objTo = objMailItem.To
objCC = objMailItem.CC
If objMailItem.Attachments.Count > 0 And _
Subject_Match(objSubject) = True And _
Date_Match(objReceivedTime) = True And _
SenderToCC_Match(objSenderName, objTo, objCC) Then
'Write log by mail with attachement
'Properties possible
'.Subject
'.Attachments.Count
'.UnRead
'.SenderName
'.ReceivedTime
'.LastModificationTime
'.ReplyRecipientNames
'.SentOn
'.Body
On Error Resume Next
FirstFileHeader = True
For i = 1 To objMailItem.Attachments.Count
Set pj = objMailItem.Attachments.Item(i)
If FileSize_Match(pj.Size) = True _
And FileType_Match(pj.DisplayName) = True _
And FileName_Match(pj.DisplayName) = True Then
FinalNameCount = 0
FileNameLegal = LegalizeFileName(pj.DisplayName) 'removing unwanted chars, usefull for email attached
FinalName = FileNameLegal
While FileOrFolderExists(Att_Path & FinalName) = True 'if file already exist, a number will be implemente between filename & extenstion like filname(23).txt
FinalNameCount = FinalNameCount + 1 'FinalNameCount is the index used to get unique name
FinalName = FileNumbering(FileNameLegal, FinalNameCount) 'this function implement the number between filename & extenstion
Wend
pj.SaveAsFile Att_Path & FinalName 'Save the attached files
Set pj = Nothing
If FirstFileHeader = True Then
objLog.WriteLine "<tr>" & _
"<td>" & objMailItem.SenderName & " </td>" & _
"<td>" & Replace(objTo, ";", "<br>") & " </td>" & _
"<td>" & Replace(objCC, ";", "<br>") & " </td>" & _
"<td>" & objSubject & " </td>" & _
"<td>" & objMailItem.ReceivedTime & "</td>" & _
"<td>" 'Start of file attached HTML part
FirstFileHeader = False
End If
objLog.WriteLine "<a target=""_blank"" href=""" & FinalName & """>" & FinalName & "</a><br>" ' Middle of file attached HTML part
Cpt = Cpt + 1
End If
Next
objLog.WriteLine "</td></tr>" 'End of file attached HTML part
If Delete_Param = 0 Then
'do nothing ! Mouhahahahaha
End If
If Delete_Param = 1 Then
While objMailItem.Attachments.Count > 0 'as the count decrement everytime a file is deleted, cannot use for, but use item(1), and repeat while count > 0
objMailItem.Attachments.Item(1).Delete 'delete the attached files
Wend
objMailItem.Save 'need to save the mail to apply the file(s) deletion
End If
If Delete_Param = 2 Then
objMailItem.Delete 'The mail is delete. I kept this function as it was in the initial macro, but it's dangerous. There is two a warns about it
End If
If Not Err.Number = 0 Then
objLog.WriteLine "<a target=""_blank"" href=""" & FinalName & """>" & FinalName & "</a> #ERROR<br>" ' Middle of file attached HTML part
End If
End If
Next
PercentLabel = "100%" 'force the 100%, otherwise, it ends at int(99.99999999999999999999) so 99% : that's not serious
objLog.WriteLine "</tr></table><br><i>" & Cpt & " attachment(s) treated</i></BODY></HTML>"
End Sub
Private Sub Att_Proc_Recur(ByRef tv As TreeView, ByRef nodThis As Node, DestinationDir As String, LogFileName As String, Delete_Param As Integer)
Dim lngIndex As Long
Dim FolderName(200) As String
Dim Outlook_Archive As String
Dim Outlook_Path As String
Dim Real_Path As String
If nodThis.Children > 0 Then
lngIndex = nodThis.Child.Index
Call Att_Proc_Recur(tv, tv.Nodes(lngIndex), DestinationDir, LogFileName, Delete_Param)
While lngIndex <> nodThis.Child.LastSibling.Index
lngIndex = tv.Nodes(lngIndex).Next.Index
Call Att_Proc_Recur(tv, tv.Nodes(lngIndex), DestinationDir, LogFileName, Delete_Param)
Wend
End If
SelItem = nodThis.Index
i = 1
While SelItem <> 1
FolderName(i) = tvw.Nodes.Item(SelItem)
i = i + 1
SelItem = tvw.Nodes(SelItem).Parent.Index
Wend
'Outlook root is Item (0)
'Outlook archive is supposed to be the Item -1 (1)
Outlook_Archive = FolderName(i - 1)
Outlook_Path = ""
'Other Folder & Subfoler are item - x (x > 1)
For j = i - 2 To 1 Step -1
Outlook_Path = Outlook_Path & FolderName(j) & "/"
Next
Outlook_Path = Left(Outlook_Path, Len(Outlook_Path) - 1) 'remove the last "\" or it will confuse the Split function in Att_Proc
Real_Path = Replace(Outlook_Path, "/", "\") & "\" 'cheating... will pay for it one day
CreateSubDirectories (DestinationDir & LegalizeFolderName(Real_Path))
Att_Proc Outlook_Archive, Outlook_Path, DestinationDir & LegalizeFolderName(Real_Path), LogFileName, Delete_Param
'MsgBox (nodThis.Index)
End Sub
Private Function FileNumbering(NomFichier As String, NumFichier As Integer) As String
Dim DotPos As Integer
If InStr(1, NomFichier, ".") = 0 Then 'if not "." exist, it means, not extension
FileNumbering = NomFichier & "(" & NumFichier & ")"
Else
While Left(Right(NomFichier, DotPos), 1) <> "." 'find the first "." from the right, which is supposed to be the start of the extension
DotPos = DotPos + 1
Wend
FileNumbering = Left(NomFichier, Len(NomFichier) - DotPos) & "(" & NumFichier & ")." & Right(NomFichier, DotPos - 1)
End If
End Function
Private Sub Opt_Del_Att_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Opt_Del_Att = True Then
If MsgBox("Are you sure you want to delete the attachement, after the files are extraceted ???", vbOKCancel, "WARNING") = vbCancel Then
Opt_Del_Att = False
Opt_Nothing = True
Cancel = True
End If
End If
End Sub
Private Sub Opt_Del_Mail_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Opt_Del_Mail = True Then
If MsgBox("Are you sure you want to delete the mail, after the files are extraceted ???", vbOKCancel, "WARNING") = vbCancel Then
Opt_Del_Mail = False
Opt_Nothing = True
Cancel = True
End If
End If
End Sub
Private Sub UserForm_Initialize()
PercentLabel = ""
Dim olApp As Outlook.Application
Dim olNameSpace
Dim olFolder As Outlook.MAPIFolder
Dim tvNode As MSComctlLib.Node
Dim tvRoot As MSComctlLib.Node
Set olApp = GetObject(, "Outlook.Application")
Set tvRoot = tvw.Nodes.Add(Text:="Outlook")
Set olNameSpace = olApp.GetNamespace("MAPI")
GetSubFolders olNameSpace, tvRoot
Set tvNode = Nothing
Set olFolder = Nothing
Set olNameSpace = Nothing
Set tvRoot = Nothing
Set olApp = Nothing
'Addint Combo box criteria
CB_Subject.AddItem "Contains"
CB_Subject.AddItem "Is"
CB_Subject.AddItem "Is not"
CB_Subject.ListIndex = 0
CB_Send.AddItem "After"
CB_Send.AddItem "Before"
CB_Send.AddItem "Between"
CB_Send.AddItem "This day"
CB_Send.ListIndex = 0
CB_SenderToCC.AddItem "Contains"
CB_SenderToCC.AddItem "Is"
CB_SenderToCC.AddItem "Is not"
CB_SenderToCC.ListIndex = 0
Opt_Kb.Value = True
CB_FileSize.AddItem "Bigger Than"
CB_FileSize.AddItem "Smaller Than"
CB_FileSize.ListIndex = 0
CB_FileType.AddItem "Office docs"
CB_FileType.AddItem "Excel"
CB_FileType.AddItem "Word"
CB_FileType.AddItem "PowerPoint"
CB_FileType.AddItem "PDF"
CB_FileType.AddItem "Pictures"
CB_FileType.AddItem "Text"
CB_FileType.AddItem "Archives"
CB_FileType.AddItem "No Type"
CB_FileType.ListIndex = 0
CB_FileName.AddItem "Contains"
CB_FileName.AddItem "Is"
CB_FileName.ListIndex = 0
End Sub
Private Function FileType_Match(NomFichier As String) As Boolean
Dim DotPos As Integer
Dim myType As String
Dim formType, thisType As Variant
If Chk_FileType = False Then
FileType_Match = True
Exit Function
End If
FileType_Match = False
If InStr(1, NomFichier, ".") = 0 Then 'if not "." exist, it means, not extension
If InStr(1, TB_FileType, "*[blank]") > 0 Then
FileType_Match = True
Else
FileType_Match = False
End If
Exit Function
Else
While Left(Right(NomFichier, DotPos), 1) <> "." 'find the first "." from the right, which is supposed to be the start of the extension
DotPos = DotPos + 1
Wend
myType = Right(NomFichier, DotPos - 1)
End If
formType = Split(TB_FileType, ";")
For Each thisType In formType
If InStr(1, thisType, myType) > 0 Then
FileType_Match = True
End If
Next
End Function
Function FileSize_Match(myFileSize As Long) As Boolean
Dim byteSize As Long
If Chk_FileSize = False Or TB_FileSize = "" Then
FileSize_Match = True
Exit Function
End If
If Opt_Kb = True Then
byteSize = Int(TB_FileSize) * 1024
Else
byteSize = Int(TB_FileSize) * 1024 * 1024
End If
FileSize_Match = False
If CB_FileSize = "Bigger Than" Then
If myFileSize >= byteSize Then FileSize_Match = True
ElseIf cbfilesize = "Smaller Than" Then
If myFileSize <= byteSize Then FileSize_Match = True
End If
End Function
Function FileName_Match(myAttachement As String) As Boolean
If Chk_FileName = False Then
FileName_Match = True
Exit Function
End If
FileName_Match = False
If CB_FileName = "Is" And UCase(TB_FileName) = UCase(myAttachement) Then
FileName_Match = True
ElseIf CB_FileName = "Contains" And InStr(1, UCase(myAttachement), UCase(TB_FileName)) > 0 Then
FileName_Match = True
End If
End Function
Function Subject_Match(Mail_Subject As String) As Boolean
If Chk_Subject = False Then
Subject_Match = True
Exit Function
End If
Subject_Match = False
If CB_Subject = "Is" And UCase(TB_Subject) = UCase(Mail_Subject) Then
Subject_Match = True
ElseIf CB_Subject = "Is not" And UCase(TB_Subject) <> UCase(Mail_Subject) Then
Subject_Match = True
ElseIf CB_Subject = "Contains" And InStr(1, UCase(Mail_Subject), UCase(TB_Subject)) > 0 Then
Subject_Match = True
End If
End Function
Function SenderToCC_Match(Sender_Mail As String, To_Mail As String, CC_Mail As String) As Boolean
If Chk_SenderToCC = False Then
SenderToCC_Match = True
Exit Function
End If
SenderToCC_Match = False
If CB_SenderToCC = "Is" And (UCase(TB_SenderToCC) = UCase(Sender_Mail) _
Or UCase(TB_SenderToCC) = UCase(To_Mail) _
Or UCase(TB_SenderToCC) = UCase(CC_Mail)) Then
SenderToCC_Match = True
ElseIf CB_SenderToCC = "Is not" And (InStr(1, UCase(Sender_Mail), UCase(TB_SenderToCC)) = 0 _
And InStr(1, UCase(To_Mail), UCase(TB_SenderToCC)) = 0 _
And InStr(1, UCase(CC_Mail), UCase(TB_SenderToCC)) = 0) Then
SenderToCC_Match = True
ElseIf CB_SenderToCC = "Contains" And (InStr(1, UCase(Sender_Mail), UCase(TB_SenderToCC)) > 0 _
Or InStr(1, UCase(To_Mail), UCase(TB_SenderToCC)) > 0 _
Or InStr(1, UCase(CC_Mail), UCase(TB_SenderToCC)) > 0) Then
SenderToCC_Match = True
End If
End Function
Function Date_Match(Mail_Date As Date) As Boolean
If Chk_Send = False Then
Date_Match = True
Exit Function
End If
Date_Match = False
If CB_Send = "Before" And Mail_Date <= Date_1 Then
Date_Match = True
ElseIf CB_Send = "After" And Mail_Date >= Date_1 Then
Date_Match = True
ElseIf CB_Send = "Between" And Mail_Date >= Date_1 And Mail_Date <= Date_2 Then
Date_Match = True
ElseIf CB_Send = "This day" And Mail_Date = Date_1 Then
Date_Match = True
End If
End Function
Private Sub GetSubFolders(olFolder, tvNode As MSComctlLib.Node)
Dim tvChild As MSComctlLib.Node
Dim olSubFolder As Outlook.MAPIFolder
For Each olSubFolder In olFolder.Folders
Set tvChild = tvw.Nodes.Add(Text:=olSubFolder.Name, _
Relative:=tvNode, Relationship:=tvwChild)
GetSubFolders olSubFolder, tvChild
Next olSubFolder
Set olSubFolder = Nothing
Set tvChild = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
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
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":" 'My macro will never work on a MAC, but how cares
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False 'shit happens
End Function
Function LegalizeFileName(FileName As String) As String
'This function remove all windows files unwanted chars
'Feel free to add any windows files forbidden characteres
FileName = Replace(FileName, "\", "")
FileName = Replace(FileName, "/", "")
FileName = Replace(FileName, ":", "")
FileName = Replace(FileName, "?", "")
FileName = Replace(FileName, """", "")
FileName = Replace(FileName, "<", "")
FileName = Replace(FileName, ">", "")
FileName = Replace(FileName, "|", "")
LegalizeFileName = FileName
End Function
Function LegalizeFolderName(FileName As String) As String
'This function remove all windows files unwanted chars
'Feel free to add any windows files forbidden characteres
'FileName = Replace(FileName, "\", "") --> for sure we need to keep the \ for the folders
FileName = Replace(FileName, "/", "")
FileName = Replace(FileName, ":", "")
FileName = Replace(FileName, "?", "")
FileName = Replace(FileName, """", "")
FileName = Replace(FileName, "<", "")
FileName = Replace(FileName, ">", "")
FileName = Replace(FileName, "|", "")
LegalizeFolderName = FileName
End Function
Sub CreateSubDirectories(fullPath As String)
Dim str As String
Dim strArray As Variant
Dim i As Long
Dim basePath As String
Dim newPath As String
str = fullPath
' add trailing slash
If Right$(str, 1) <> "\" Then
str = str & "\"
End If
' split string into array
strArray = Split(str, "\")
basePath = strArray(0) & "\"
' loop through array and create progressively
' lower level folders
For i = 1 To UBound(strArray) - 1
If Len(newPath) = 0 Then
newPath = basePath & newPath & strArray(i) & "\"
Else
newPath = newPath & strArray(i) & "\"
End If
If Not FileOrFolderExists(newPath) Then
MkDir newPath
End If
Next i
End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.