General VBA, Outlook

Export Outlook Folders to the File System

Leave a comment

The following will allow you to export the folder you have selected in outlook to a folder on your file system. The messages are exported as msg.

Many thanks to https://techniclee.wordpress.com/2013/05/09/export-outlook-folders-to-the-file-system/
Only changes made –

  • Filelength was too long some times
  • white spaces in the file path.
  • Invalid Characters in the folder path
  • Added error handler in to track errors.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
'On the next line edit the starting folder as desired. If you leave it blank, then the starting folder will be the local computer.
Const STARTING_FOLDER = ""

Dim objFSO As Object

Sub CopyOutlookFolderToFileSystem()
ExportController "Copy"
End Sub

Sub MoveOutlookFolderToFileSystem()
'not use the move function
' ExportController "Move"
End Sub

Sub ExportController(strAction As String)
Dim olkFld As Outlook.MAPIFolder, strPath As String
strPath = SelectFolder(STARTING_FOLDER)
If strPath = "" Then
MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Export Outlook Folder"
Else
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set olkFld = Application.ActiveExplorer.CurrentFolder
ExportOutlookFolder olkFld, strPath
If LCase(strAction) = "move" Then olkFld.Delete
End If
Set olkFld = Nothing
Set objFSO = Nothing
End Sub
Function trimSubject(ByVal theSubject As String, Optional ByVal thePath As String) As String
If Len(theSubject) > 128 Then
trimSubject = Trim(Left(theSubject, 127))
Else
trimSubject = Trim(theSubject)
End If
If Len(thePath & theSubject) > 255 Then
Dim subjectcount As Integer
subjectcount = Len(theSubject) - (Len(thePath & theSubject) - 255)
If subjectcount > 0 Then
trimSubject = Trim(Left(theSubject, subjectcount))
End If
End If
End Function
Sub ExportOutlookFolder(ByVal olkFld As Outlook.MAPIFolder, strStartingPath As String)
On Error GoTo ErrorHanDler
Dim olkSub As Outlook.MAPIFolder, olkItm As Object, strPath As String, strMyPath As String, strSubejct As String, intCount As Integer
strPath = Trim(strStartingPath) & "" & Trim(RemoveIllegalCharacters(olkFld.Name))
objFSO.CreateFolder strPath
For Each olkItm In olkFld.Items
strSubject = trimSubject("[From] " & olkItm.SenderName & " [Subject] " & RemoveIllegalCharacters(olkItm.Subject), strPath)
strFilename = Trim(strSubject) & ".msg"
intCount = 0
Do While True
strMyPath = Trim(strPath) & "" & Trim(strFilename)
If objFSO.FileExists(strMyPath) Then
intCount = intCount + 1
strFilename = Trim(strSubject) & " (" & intCount & ").msg"
' strMyPath = Trim(strPath) & "" & strSubject & " (" & intCount & ").msg"
Else
Exit Do
End If
Loop

olkItm.SaveAs strMyPath, olMSG

ChangeTimeStamp strMyPath, olkItm.ReceivedTime
Next
For Each olkSub In olkFld.Folders
ExportOutlookFolder olkSub, strPath
Next
Set olkFld = Nothing
Set olkItm = Nothing

Exit Sub

ErrorHanDler:
MsgBox (strPath)

MsgBox Len(strMyPath)
MsgBox strMyPath

Resume

End Sub

Function SelectFolder(varStartingFolder As Variant) As String
' This function is a modified version of the SelectFolder function written by Rob van der Woude (http://www.robvanderwoude.com/vbstech_ui_selectfolder.php)

' Standard housekeeping
Dim objFolder As Object, objShell As Object

' Custom error handling
On Error Resume Next

' Create a dialog object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Select the folder you want to export to", 0, varStartingFolder)

' Return the path of the selected folder
If TypeName(objFolder) <> "Nothing" Then SelectFolder = objFolder.self.Path

' Standard housekeeping
Set objFolder = Nothing
Set objShell = Nothing
On Error GoTo 0
End Function

Function RemoveIllegalCharacters(strValue As String) As String
' Purpose: Remove characters that cannot be in a filename from a string.'
' Written: 4/24/2009'
' Author: BlueDevilFan'
' Outlook: All versions'
RemoveIllegalCharacters = strValue
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "") RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function

Sub ChangeTimeStamp(strFile As String, datStamp As Date)
Dim objShell As Object, objFolder As Object, objFolderItem As Object, varPath As Variant, varName As Variant
varName = Mid(strFile, InStrRev(strFile, "") + 1)
varPath = Mid(strFile, 1, InStrRev(strFile, ""))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(varPath)
Set objFolderItem = objFolder.ParseName(varName)
objFolderItem.ModifyDate = CStr(datStamp)
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Sub
General VBA

VBA Resize all pictures in document

Leave a comment

Many thanks for the below code from

http://www.vbaexpress.com/forum/showthread.php?21618-Formatting-Pictures-(InlineShapes)-with-Aspect-Ratio

 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub FormatPictures()
     
    Dim maxW As Double: maxW = CentimetersToPoints(14)
    Dim maxH As Double: maxH = CentimetersToPoints(11)
     
    Dim š As InlineShape
    Dim r As Double ' Width/Height ratio
     
    For Each š In ActiveDocument.InlineShapes
        r = š.Width / š.Height 'aspect ratio AR
        If (š.Width > maxW) Then
            š.Width = maxW 'resize horizontally
            š.Height = š.Width / r 'keep AR
        End If
        If (š.Height > maxH) Then
            š.Height = maxH 'resize vertically
            š.Width = š.Height * r 'keep AR
        End If
    Next š
     
End Sub
General VBA

Arrays

Leave a comment

Do not be shy about using arrays, they are not hard to use.

   Dim people(2) As String
   people(0) = "John Henry"
   people(1) = "Catherine Weaver"
   MsgBox UBound(people)
   'access the first element in the array
   MsgBox people(0)

The split() function will make arrays to play with. For this example we are going to use split(string) and split(string, delimiter). The function returns an array of strings or string if it can not find the delimiter.

Dim myarray() as string
Dim mytext as string
Mytext = "the big red dog sat on the hill"
Myarray = split(mytext)
Dim index as integer
Index = 0
Dim output as string
Output = ""
For index to ubound(Myarray) -1
   Output = output & "index:" & index & " " & myarray(index)
Next index
Msgbox output

 

General VBA

String – Functions

Leave a comment

Some examples for common functions.

length of a string “Len()”

dim mystring as String
mystring = "Hello World"
msgbox Len(mystring)

len

Next “Left()” and “Right()” using the “Hello World”

msgbox Left(mystring, 5)

left

msgbox Right(mystring, 5)

Right
There pretty easy, but there is also the “Mid(String, Integer)” and “Mid(String, Integer, Integer)”

MsgBox Mid(mystring, 5)

mid-5

MsgBox Mid(mystring, 2, 5)

mid-2.5
These are just a few check the Microsoft page out for more.

General VBA

String – Introduction

Leave a comment

The Basics
If you have completed a hello word example then you have seen a string.  You can do many interesting things with strings but lets start with the basics.
To declare a string and set its value

dim myfirst as string
myfirst = "abc123"

Join 2 string together

dim mysecond as string
mysecond = "efg123"
msgbox myfirst & " " & mysecond

Remember to place the code in a sub routine. Here is the code below

Sub stringcombine()
   Dim myfirststring As String
   myfirst = "abc123"
   Dim mysecond As String
   mysecond = "efg123"
   MsgBox myfirst & " " & mysecond
End Sub
String Basics
String Basics