Outlook 2010 : coloring mail folders? - colors

Any one knows how to get colored folders in Outlook 2010 ?
There is no such functionality integrated in Outlook... Is there another way ? VBA ? How does it works ?
Thanks.

No, colored folders in Outlook still have not been implemented.

I implemented a work-around basing on:
designing icons consisting of a colored square (red, blue, green, etc.)
storing icons in a defined local directory
assigning programmatically (VBA) the icons to the mail folders.
Result:
Example
HOWTO
Create icons files (e.g. red.ico, blue.ico) in C:\icons or unzip this file to C:\icons icons
Define the VBA code below and adapt the function ColorizeOutlookFolders according to your needs
Code:
Function GetFolder(ByVal FolderPath As String) As Outlook.folder
' Returns an Outlook folder object basing on the folder path
'
Dim TempFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolder_Error
'Remove Leading slashes in the folder path
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TempFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not TempFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TempFolder.Folders
Set TempFolder = SubFolders.Item(FoldersArray(i))
If TempFolder Is Nothing Then
Set GetFolder = Nothing
End If
Next
End If
'Return the TempFolder
Set GetFolder = TempFolder
Exit Function
GetFolder_Error:
Set GetFolder = Nothing
Exit Function
End Function
Sub ColorizeOneFolder(FolderPath As String, FolderColour As String)
Dim myPic As IPictureDisp
Dim folder As Outlook.folder
Set folder = GetFolder(FolderPath)
Set myPic = LoadPicture("C:\icons\" + FolderColour + ".ico")
If Not (folder Is Nothing) Then
' set a custom icon to the folder
folder.SetCustomIcon myPic
'Debug.Print "setting colour to " + FolderPath + " as " + FolderColour
End If
End Sub
Sub ColorizeFolderAndSubFolders(strFolderPath As String, strFolderColour As String)
' this procedure colorizes the foler given by strFolderPath and all subfolfers
Dim olProjectRootFolder As Outlook.folder
Set olProjectRootFolder = GetFolder(strFolderPath)
Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempFolder As Outlook.MAPIFolder
Dim strTempFolderPath As String
' colorize folder
Call ColorizeOneFolder(strFolderPath, strFolderColour)
' Loop through the items in the current folder.
For i = olProjectRootFolder.Folders.Count To 1 Step -1
Set olTempFolder = olProjectRootFolder.Folders(i)
strTempFolderPath = olTempFolder.FolderPath
'prints the folder path and name in the VB Editor's Immediate window
'Debug.Print sTempFolderPath
' colorize folder
Call ColorizeOneFolder(strTempFolderPath, strFolderColour)
Next
For Each olNewFolder In olProjectRootFolder.Folders
' recursive call
'Debug.Print olNewFolder.FolderPath
Call ColorizeFolderAndSubFolders(olNewFolder.FolderPath, strFolderColour)
Next
End Sub
Sub ColorizeOutlookFolders()
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\100-People", "blue")
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\200-Projects", "red")
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\500-Meeting", "green")
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\800-Product", "magenta")
Call ColorizeFolderAndSubFolders("\\Personal\Documents\000-Mgmt-CH\600-Departments", "grey")
Call ColorizeFolderAndSubFolders("\\Mailbox - Dan Wilson\Inbox\Customers", "grey")
End Sub
To launch colorizing at Outlook startup, in the VBA object ThisOutlookSession, define the following function:
Private Sub Application_Startup()
ColorizeOutlookFolders
End Sub

Related

Problems with VBA Script - Find User who has an excel file open using network share

I am using the following VBA function from Ryan Wells to find which user has an Excel open.
Function Excel_File_in_use_by(FilePath As String) As String
Dim strTempFile As String
Dim iPos As Integer, iRetVal As Integer
Dim objFSO As Object, objWMIService As Object, objFileSecuritySettings As Object, objSD As Object
iPos = InStrRev(FilePath, "\")
strTempFile = Left(FilePath, iPos - 1) & "\~$" & Mid(FilePath, iPos + 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strTempFile) Then
Set objWMIService = GetObject("winmgmts:")
Set objFileSecuritySettings = objWMIService.Get("Win32_LogicalFileSecuritySetting='" & strTempFile & "'")
iRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If iRetVal = 0 Then
Excel_File_in_use_by = objSD.Owner.Name
Else
Excel_File_in_use_by = "unknown"
End If
Set objWMIService = Nothing
Set objFileSecuritySettings = Nothing
Set objSD = Nothing
Else
Excel_File_in_use_by = vbNullString
End If
Set objFSO = Nothing
End Function
The codes works great when I supply the file path and it begins with a mapped network drive, for example j:\Workbook.xlsx. But when the file path is passed in as a network address, for example \\server1\Workbook.xlsx I get runtime error '-2147217406 (80041002)'.
This was my test sub and the 2nd statement is giving me the runtime error
Sub test()
Debug.Print Excel_File_in_use_by("J:\Workbook.xlsx")
Debug.Print Excel_File_in_use_by("\\server1\Workbook.xlsx")
End Sub
Is it possible to use this code or amended it to be able to pass in file path in the network address as sometimes this is required as not all drives will be mapped.

Loop through all subfolders

I am trying to loop through all subfolders. This script works but then only pulls some folders and not others. I need it to pull all files in the folder. I did not create this full script but would like to modify it.
UPDATE:
I tried this alternate solution below and it works.
Sub loopAllSubFolderSelectStartDirectory()
Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim folderName As String
'Set the folder name to a variable
folderName = "C:\Users\dreid_000\Desktop\PhaseII\"
'Set the reference to the FSO Library
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
'Another Macro must call LoopAllSubFolders Macro to start
LoopAllSubFolders FSOLibrary.GetFolder(folderName)
End Sub
Sub LoopAllSubFolders(FSOFolder As Object)
Dim FSOSubFolder As Object
Dim FSOFile As Object
Dim soldname As String
Dim sNewName As String
Dim sTempFile() As String
Dim sPath As String
Set Fso = CreateObject("Scripting.FileSystemObject")
'For each subfolder call the macro
For Each FSOSubFolder In FSOFolder.subfolders
LoopAllSubFolders FSOSubFolder
Next
'For each file, print the name
For Each FSOFile In FSOFolder.Files
'Insert the actions to be performed on each file
FSOFile.Name = "PhaseII.xlsx"
'This example will print the full file path to the immediate window
Debug.Print FSOFile.Path
Next
End Sub
Here is a good, generic solution that can meet basically any search folder and its subfolders requirements. It is a function that calls itself recursively and outputs a dictionary object containing the complete results, code commented for clarity:
Public Function SearchDirectory(ByVal arg_sFolderPath As String, _
Optional ByVal arg_sSearch As String = "*", _
Optional ByVal arg_bMatchCase As Boolean = False, _
Optional ByVal arg_bIncludeSubFolders As Boolean = True, _
Optional ByRef arg_hResults As Object) _
As Object
'Purpose of this function is to search a directory (and probably all of its subfolders)
'for files that match an optionally provided search string, and the match may or may
'not be case sensitive. It then collects all of the results in a dictionary object and
'returns that dictionary object as the function output
'
'Parameters:
' arg_sFolderPath: [Required][String] -The folder path of the original directory that will be searched
'
' arg_sSearch: [Optional][String] -A pattern that will be matched against.
' -For example, to find all Excel files you would use "*.xls*"
' -Default value is "*" which will return all files
'
' arg_bMatchCase: [Optional][Boolean] -Specifies whether or not to match arg_sSearch as case sensitive
' -For example, if this is set to True and the arg_sSearch is set to "*.xls*",
' then an Excel file named "EXCELFILE.XLSX" would NOT be found
' -Default value is False which will make matches not case sensitive
'
' arg_bIncludeSubFolders [Optional][Boolean] -Specifies whether or not to search all subfolders recursively
' -Default value is True which will include results in all subfolders
'
' arg_hResults [Optional][Dictionary Object] -An existing dictionary object to hold the results in
' -Typically this will not be provided on initial call, and is used
' during recursive calls to store all relevant results for output
'
'Author: tigeravatar on stackoverflow at https://stackoverflow.com/questions/56970854/loop-through-all-subfolders
'Created: July 10, 2019
'Static so that during recursive search it doesn't need to be recreated on every recursive call
Static oFSO As Object
If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
'Check if arg_hResults was provided (typically not on first call, but will be on all subsequent recursive calls)
'This preserves all found matching file results throughout all recursive calls of the function
Dim hResults As Object
If arg_hResults Is Nothing Then Set hResults = CreateObject("Scripting.Dictionary") Else Set hResults = arg_hResults
'Variable used to store the folder path separator
Dim sPS As String
sPS = Application.PathSeparator
'Adjust so that even if folder path isn't passed with an ending Path Separator, the function can handle it appropriately
Dim sFolderPath As String
If Right(arg_sFolderPath, Len(sPS)) = sPS Then sFolderPath = arg_sFolderPath Else sFolderPath = arg_sFolderPath & sPS
'Verify the folder path provided is valid. Allow for hidden folders to be searched as well
If Len(Dir(sFolderPath, vbDirectory + vbHidden)) = 0 Then
MsgBox "Invalid directory path provided: " & Chr(10) & arg_sFolderPath, , "Search Directory Error"
Set SearchDirectory = Nothing
Exit Function
End If
'Using the FileSystemObject, work with the provided and validated folder path
Dim oFolder As Object
Set oFolder = oFSO.GetFolder(sFolderPath)
'Loop through all files in the folder
Dim oFile As Object
Dim bMatch As Boolean
For Each oFile In oFolder.Files
'Verify the file matches the provided search pattern (if any) according to case sensitivity
bMatch = False
If arg_bMatchCase = True Then
If oFile.Name Like arg_sSearch Then bMatch = True
Else
If LCase(oFile.Name) Like LCase(arg_sSearch) Then bMatch = True
End If
'If match found, add it to the hResults dictionary
If bMatch = True Then
If Not hResults.Exists(oFile.Path) Then hResults.Add oFile.Path, oFile.Path
End If
Next oFile
'If set to search subfolders (default behavior), have the function recursively call itself to search all subfolders
If arg_bIncludeSubFolders = True Then
Dim oSubFolder As Object
For Each oSubFolder In oFolder.SubFolders
Set hResults = SearchDirectory(oSubFolder.Path, arg_sSearch, arg_bMatchCase, arg_bIncludeSubFolders, hResults)
Next oSubFolder
End If
'Set function output to the hResults dictionary if it contains any matched file results
If hResults Is Nothing Then
Set SearchDirectory = Nothing
Else
If hResults.Count = 0 Then Set SearchDirectory = Nothing Else Set SearchDirectory = hResults
End If
End Function
This is an example of how to use the function and work with its results:
Sub tgr()
'Create an object variable and set it to the function SearchDirectory
'Provide SearchDirectory arguments as desired
Dim hFoundFiles As Object
Set hFoundFiles = SearchDirectory("C:\Test")
'Verify it actually found files matching your criteria in the folder specified
If hFoundFiles Is Nothing Then Exit Sub 'Didn't return any results
'Can output results to a worksheet
ActiveWorkbook.ActiveSheet.Range("A1").Resize(hFoundFiles.Count).Value = Application.Transpose(hFoundFiles.Keys)
'Can loop through each result if you need to do something with them individually
Dim vFile As Variant
For Each vFile In hFoundFiles.Keys
'Do something here
Debug.Print vFile
Next vFile
End Sub

Read File From Sharepoint

I'm writing a script where I wish to write an HTML doc to a string from sharepoint.
Dim Content As String
Dim strShare As String: strShare = "\\link\to\share.html"
Dim iFile As Integer: iFile = FreeFile
Open strShare For Input As #iFile
Content = Input(LOF(iFile), iFile)
Close #iFile
However, I find I get a "path/file access error" every time I run the script for the first time upon boot. Once I visit "\link\to\share.html" in IE for the first time, the path begins to resolve in the VBA script.
My only thought is that IE is performing some sort of "DNS Cache" that VBA can't do. Currently my workaround is to catch the error and force the URL to open in IE the first time the script is run. After that, every other HTML file under that share loads fine.
As a test, I tried switching between from what I understand is http:// formatting (forward slash) and WebDAV formatting (\\ formating), and only the backslash separated paths ever work. I also tried to resolve the share to an IP and try it that way, but that never worked.
My last thought is to try mapping the share to a drive letter name and then specifically accessing the share with G:\link\to\mapped\share.html. But I don't see this as an elegant solution, and wonder if it will receive the same error any way.
Is there something blatant that I do not understand about WebDAV, Windows file handling, and VBA file inputs? There's something weird going on under the hood with resolving that shared domain, and I can't seem to debug it.
See if this helps here and an example below that I used.
2 things though: I only worked with Excel files on Sharepoint and I was already logged in there.
Dim oFSO As Object
'Dim oFolder As Object 'if needed
'Dim oFile As Object 'if needed
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("\\sharepoint.site.com#SSL\DavWWWRoot\sites\")
'For Each oFolder In oFolder.SubFolders 'loops through folders
' For Each oFile In oFolder.Files 'loops through files
' 'do stuff
' Next oFile
'Next oFolder
I'm a bit confused about what you want to do. Do you want to check out files from SP and check files back into SP?
Sub testing()
Dim docCheckOut As String
'docCheckOut = "//office.bt.com/sites/Training/Design Admin/Training Plan/adamsmacro.xlsm"
docCheckOut = "http://your_path_here/ExcelList.xlsb"
Call UseCheckOut(docCheckOut)
End Sub
Sub UseCheckOut(docCheckOut As String)
' Determine if workbook can be checked out.
If Workbooks.CanCheckOut(docCheckOut) = True Then
Workbooks.CheckOut docCheckOut
Else
MsgBox "Unable to check out this document at this time."
End If
End Sub
Or...do you want to list files in a SP folder?
Sub ListFiles()
Dim folder As Variant
Dim f As File
Dim fs As New FileSystemObject
Dim RowCtr As Integer
Dim FPath As String
Dim wb As Workbook
RowCtr = 1
FPath = "http://excel-pc:43231/Shared Documents"
For Each f In FPath
'Set folder = fs.GetFolder("C:\Users\Excel\Desktop\Ryan_Folder")
'For Each f In folder.Files
Cells(RowCtr, 1).Value = f.Name
RowCtr = RowCtr + 1
Next f
End Sub
Sub test()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\Excel\Desktop\Ryan_Folder")
'Set colSubfolders = objFolder.SubFolders
'For Each objSubfolder In colSubfolders
Cells(RowCtr, 1).Value = f.Name
RowCtr = RowCtr + 1
'Next
End Sub

Extract a folder name from file path

I have a file path (which is a connection path for the worksheet) in the following format:
C:\ExcelFiles\Data\20140522\File1_20140522.csv
I want to extract 20140522.
I tried using responses of How to extract groups of numbers from a string in vba, but they don't seem to work in my case.
please find below
Filename = "C:\ExcelFiles\Data\20140522\File1_20140522.csv"
a = Replace(Mid(Filename, InStrRev(Filename, "_") + 1, Len(Filename)), ".csv", "")
Try the following. Folder is selected.
Sub Folder_S()
Dim sFolder As FileDialog
On Error Resume Next
Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
If sFolder.Show = -1 Then
Folder_Select sFolder.SelectedItems(1), True
End If
End Sub
Sub Folder_Select(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim SourceFolder As Object
Dim FileItem As Object
Dim strFile As String
Dim FileName As Variant
Dim pathParts() As String
Dim pathPart As String
Dim i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
pathParts = Split(SourceFolder.Path, Application.PathSeparator)
pathPart = SourceFolder.Path
For i = 0 To UBound(pathParts)
If pathParts(i) = "20140522" Then
pathPart = pathParts(i - 0)
Exit For
End If
Next i
Row = ActiveCell.Row
With CreateObject("Scripting.Dictionary")
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
.Item(strFile) = Array(FileItem.Name)
Next FileItem
If .Count > 0 Then
For Each FileName In .Items
Cells(Row, 2).Formula = pathPart
Next FileName
End If
End With
End Sub
I found your question by searching a solution how to get a folder path from a file that is inside this folder path. But your question doesn't match exactly what I need. For those who by your question title will find it for the same purpose as I found, below is my function:
Function getFolderPathFromFilePath(filePath As String) As String
Dim lastPathSeparatorPosition As Long
lastPathSeparatorPosition = InStrRev(filePath, Application.PathSeparator)
getFolderPathFromFilePath = Left(filePath, lastPathSeparatorPosition - 1)
End Function
In some solutions for this purpose, I used FSO, but it takes resources, and I think it isn't worthy to create FSO object if you need it only for this simple function.
the accepted answer is not accurate to read the folder name. here is more dynamic code.
use splitter which splits string based on delimeter and makes an array. now read the second last element in array, thats the folder name.
Dim fileName As String
fileName = "C:\ExcelFiles\Data\20140522\File1_20140522.csv"
Dim vPathSplitter As Variant
vPathSplitter = Split(fileName, "\")
MsgBox (vPathSplitter(UBound(vPathSplitter) - 1))
The below answer gets your file path from a range, rather than a fixed string. Much more handy if your planning on getting your filename from your sheets, which I imagine you are.
Sub GetFileDate()
Dim filename As String
filename = Sheets("Sheet1").Range("C9").Value 'Or Wherever your file path is
MsgBox Replace(Right(filename, 12), ".csv", "")
End Sub
This assumes the numbers your extracting will ALWAYS be dates in YYYYMMDD format and the file type is always .csv

Excel Macro to apend data from two notepad into a single notepad

I want to delete the last line contain '*' of two notepad and apend the reamining data into a new notepad by excel macro.
Please guys help me out. I can't find any suggestion.
Using #mehow's suggestion, here is some code that you can use:
' To get this to run, you'll need to reference Microsoft Scripting Runtime:
' Per http://stackoverflow.com/questions/3233203/how-do-i-use-filesystemobject-in-vba
' Within Excel you need to set a reference to the VB script run-time library. The relevant file is usually located at \Windows\System32\scrrun.dll
' To reference this file, load the Visual Basic Editor (ALT-F11)
' Select Tools - References from the drop-down menu
' A listbox of available references will be displayed
' Tick the check-box next to 'Microsoft Scripting Runtime'
' The full name and path of the scrrun.dll file will be displayed below the listbox
' Click on the OK button
Sub appFiles()
'File path and names for each file
Dim sFile1 As String
Dim sFile2 As String
Dim sFileLast As String
'Search string
Dim sSearchStr As String
'Delimiter used to separate/join lines
Dim sDL As String
'If the final file already exists, should it overwrite the previous _
contents (True) or append to the end of the file (False)
Dim doOverwrite As Boolean
'File contents
Dim sMsg1 As String
Dim sMsg2 As String
Dim sMsgFinal As String
sFile1 = "C:\Users\foobar\Desktop\foo.txt"
sFile2 = "C:\Users\foobar\Desktop\foo2.txt"
sFileLast = "C:\Users\foobar\Desktop\fooFinal.txt"
sSearchStr = "*"
sDL = Chr(13) & Chr(10)
doOverwrite = True
sMsg1 = appendLines(sFile1, sSearchStr, sDL)
sMsg2 = appendLines(sFile2, sSearchStr, sDL)
sMsgFinal = sMsg1 & sDL & sMsg2
Call writeToFile(sMsgFinal, sFileLast, doOverwrite)
End Sub
Function appendLines(sFileName As String, sSearchStr As String, Optional sDL As String = " ") As String
Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim oFS As TextStream
Dim sStr As String
Dim sMsg As String
If oFSO.fileexists(sFileName) Then 'Check if file exists
On Error GoTo Err
Set oFS = oFSO.openTextFile(sFileName)
'Read file
Do While Not oFS.AtEndOfStream
sStr = oFS.ReadLine
If InStr(sStr, sSearchStr) Then
appendLines = sMsg
Else
sMsg = sMsg & sStr & sDL
End If
Loop
oFS.Close
Else
Call MsgBox("The file path (" & sFileName & ") is invalid", vbCritical)
End If
Set oFS = Nothing
Set oFSO = Nothing
Exit Function
Err:
Call MsgBox("Error occurred while reading the file.", vbCritical)
oFS.Close
Set oFS = Nothing
Set oFSO = Nothing
End Function
Sub writeToFile(sMsg As String, sFileName As String, Optional doOverwrite As Boolean = False)
Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim oFS As TextStream
On Error GoTo Err
If oFSO.fileexists(sFileName) Then
If doOverwrite Then
Set oFS = oFSO.openTextFile(sFileName, ForWriting)
Else
Set oFS = oFSO.openTextFile(sFileName, ForAppending)
End If
Else
Set oFS = oFSO.CreateTextFile(sFileName, True)
End If
Call oFS.write(sMsg)
oFS.Close
Set oFS = Nothing
Set oFSO = Nothing
Exit Sub
Err:
Call MsgBox("Error occurred while writing to the file.", vbCritical)
oFS.Close
Set oFS = Nothing
Set oFSO = Nothing
End Sub
You'll need to customize the appFiles routine as needed, by providing file names to sFile1, sFile2, and sFileLast; your desired search string to sSearchStr (you mentioned using "*"); a delimiter to separate lines (it's currently written to use a carriage return and new line); and a parameter deciding whether or not to overwrite the final file (if you find yourself running this multiple times with the same final file).
Here's another link that I used while writing the code above: link - Explains how to write to a file from within a macro
Hope this helps.

Resources