objShell.BrowseForFolder dialog - how to use file shortcuts

Discussion:

(too old to reply)

Marceepoo

2008-02-06 00:22:32 UTC

We use the dialog below to set a textvar to the address of a folder.
While we are in the dialog, shortcuts (to the various folders we use often)
don't work.
How can we modify the dialog so that shortcuts to file folders will work
inside the dialog?

Here's the code:
Set objFolder = objShell.BrowseForFolder(&H0, "Select the file", _
BIF_editbox + BIF_browseincludefiles, "")
txDir4Save = objFolder.Self.Path & "\"

Any help would be much appreciated.

Thanks,
marceepoo

Ken Slovak - [MVP - Outlook]

2008-02-06 14:21:55 UTC

Permalink

How is this Outlook related?
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm

Post by Marceepoo
We use the dialog below to set a textvar to the address of a folder.
While we are in the dialog, shortcuts (to the various folders we use often)
don't work.
How can we modify the dialog so that shortcuts to file folders will work
inside the dialog?
Set objFolder = objShell.BrowseForFolder(&H0, "Select the file", _
BIF_editbox + BIF_browseincludefiles, "")
txDir4Save = objFolder.Self.Path & "\"
Any help would be much appreciated.
Thanks,
marceepoo

Marceepoo

2008-02-06 18:16:01 UTC

Permalink

I apologize for not explaining that. I was trying to avoid bothering you
with more code than you might want to see. Here's the macro I made, which is
triggered by a button which a user "pushes" when the user has opened an email
and wants to save (1) the email to an HTML file in the appropriate client's
folder, and (2) the attachments in an "Attachments" folder under the previous
folder:

The macro (see line 39) is below. Any help would be much appreciated.
BTW, if this time I put too much code here in the posting, please tell me
what would be the proper amount, ie., how to determine what to include in the
posting, so that I make your job easier instead of harder.

Thanks again, marceepoo

Sub SaveAttachmentS_05()

'----------------------------
Dim myOlApp As Outlook.Application
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim iChar2bRemoved, iAttachments, iIteration01 As Integer
Dim dlgDir4Save As Dialog
Dim txDir4Save, txDir_ClientFldr, strname, sFileFulnam, sFileFulnam4Wmi,
aAttachFulName As String
Dim aAttachFulName4Wmi, strPathsPrefix, sUsableDate, tx4Msgbox As String
Dim sPrefix, strPath As String
Dim objFSO As FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")

Set myOlApp = CreateObject("Outlook.Application")
Set myInspector = myOlApp.ActiveInspector
iIteration01 = 0

If Not TypeName(myInspector) = "Nothing" Then

'----------------------------------------------------------------------------
' Dialog box browse for folde
'http://www.microsoft.com/communities/newsgroups/list/en-us/default.aspx?dg=microsoft.public.inetsdk.programming.scripting.vbscript&tid=2d0012e2-fb4c-4859-bfb9-87416515e912&cat=en_us_8e20817c-f87a-4b7a-a3b4-423a69908f60&lang=en&cr=us&p=1
'
Const BIF_returnonlyfsdirs = &H1
Const BIF_dontgobelowdomain = &H2
Const BIF_statustext = &H4
Const BIF_returnfsancestors = &H8
Const BIF_editbox = &H10
Const BIF_validate = &H20
Const BIF_browseforcomputer = &H1000
Const BIF_browseforprinter = &H2000
Const BIF_browseincludefiles = &H4000

Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder2
Set objShell = New Shell32.Shell

'(Line 39) Open browser to select a folder. Alas, I don't
' know how to get the browser to let me use shortcuts to browse
' more quickly to the folders I typically use.
Set objFolder = objShell.BrowseForFolder(&H0, "Select the Client
Filder", _
BIF_editbox + BIF_browseincludefiles, "")
txDir_ClientFldr = objFolder.Self.Path & "\"
txDir4Save = txDir_ClientFldr & "EmailIn\"
tx4Msgbox = "txDir_ClientFldr = objFolder.Self.Path & '\' = " &
txDir_ClientFldr & vbCrLf _
& "txDir4Save = txDir_ClientFldr & 'EmailIn\' = " & txDir4Save
' MsgBox tx4Msgbox

'------------------------------------------------------------------------------
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myItem = myInspector.CurrentItem

'---------------------------------------------
'Save email item to Html file
'
With myItem

.BodyFormat = olFormatHTML
.Display
End With

sUsableDate = CStr(DatConvertedToMarcStyle(myItem.SentOn))

sPrefix = sUsableDate & "_" & myItem.SenderName
strname = sPrefix & "_" & myItem.Subject

iChar2bRemoved = InStr(3, strname, ":", vbTextCompare)

If iChar2bRemoved > 0 Then strname = Replace(strname, ":", "-_")
sFileFulnam = txDir4Save & strname & ".HTML"

sFileFulnam4Wmi = Replace(sFileFulnam, "\", "\\", vbTextCompare)

If objFSO.FileExists(sFileFulnam) Then
MsgBox "The file exists! Insert a subroutine here."
End If

myItem.SaveAs sFileFulnam, olHTML

'--------------------------------------------
'Save email attachments in Dir under the Dir where EmailItem is
saved
'
Set myAttachments = myItem.Attachments
iAttachments = myAttachments.Count
iIteration01 = iAttachments

While iIteration01 > 0
aAttachFulName = txDir4Save & "Attachments\" & sPrefix & "_"
& _
myAttachments.item(iIteration01).DisplayName

aAttachFulName4Wmi = Replace(aAttachFulName, "\", "\\",
vbTextCompare)

iIteration01 = iIteration01 - 1

If objFSO.FileExists(aAttachFulName) Then
MsgBox "The file exists! Insert a subroutine here."
End If

myAttachments.item(1).SaveAsFile (aAttachFulName)
Wend

End If
End If

strPath = "explorer.exe /e, " & txDir4Save & "Attachments\"
Call Shell(strPath, vbNormalNoFocus)

End Sub

Post by Ken Slovak - [MVP - Outlook]
How is this Outlook related?
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm

Ken Slovak - [MVP - Outlook]

2008-02-06 18:52:03 UTC

Permalink

I'm not familiar with that API but if you also have VB installed on that
machine why not use the Windows Dialog Controls OCX (ComDlg32.ocx) instead,
it provides the standard File Open dialog for you. Even if you don't have VB
installed you can directly call the DLL that the OCX calls into.

Usage of ComDlg32.ocx is demonstrated at
http://www.vb-helper.com/howto_select_file.html. This link shows how to
directly use ComDlg32.DLL from VB code, the same would work for VBA code.
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm

Post by Marceepoo
I apologize for not explaining that. I was trying to avoid bothering you
with more code than you might want to see. Here's the macro I made, which is
triggered by a button which a user "pushes" when the user has opened an email
and wants to save (1) the email to an HTML file in the appropriate client's
folder, and (2) the attachments in an "Attachments" folder under the previous
The macro (see line 39) is below. Any help would be much appreciated.
BTW, if this time I put too much code here in the posting, please tell me
what would be the proper amount, ie., how to determine what to include in the
posting, so that I make your job easier instead of harder.
Thanks again, marceepoo
Sub SaveAttachmentS_05()
'----------------------------
Dim myOlApp As Outlook.Application
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim iChar2bRemoved, iAttachments, iIteration01 As Integer
Dim dlgDir4Save As Dialog
Dim txDir4Save, txDir_ClientFldr, strname, sFileFulnam,
sFileFulnam4Wmi,
aAttachFulName As String
Dim aAttachFulName4Wmi, strPathsPrefix, sUsableDate, tx4Msgbox As String
Dim sPrefix, strPath As String
Dim objFSO As FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = CreateObject("Outlook.Application")
Set myInspector = myOlApp.ActiveInspector
iIteration01 = 0
If Not TypeName(myInspector) = "Nothing" Then
'----------------------------------------------------------------------------
' Dialog box browse for folder
'http://www.microsoft.com/communities/newsgroups/list/en-us/default.aspx?dg=microsoft.public.inetsdk.programming.scripting.vbscript&tid=2d0012e2-fb4c-4859-bfb9-87416515e912&cat=en_us_8e20817c-f87a-4b7a-a3b4-423a69908f60&lang=en&cr=us&p=1
'
Const BIF_returnonlyfsdirs = &H1
Const BIF_dontgobelowdomain = &H2
Const BIF_statustext = &H4
Const BIF_returnfsancestors = &H8
Const BIF_editbox = &H10
Const BIF_validate = &H20
Const BIF_browseforcomputer = &H1000
Const BIF_browseforprinter = &H2000
Const BIF_browseincludefiles = &H4000
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder2
Set objShell = New Shell32.Shell
'(Line 39) Open browser to select a folder. Alas, I don't
' know how to get the browser to let me use shortcuts to browse
' more quickly to the folders I typically use.
Set objFolder = objShell.BrowseForFolder(&H0, "Select the Client
Filder", _
BIF_editbox + BIF_browseincludefiles, "")
txDir_ClientFldr = objFolder.Self.Path & "\"
txDir4Save = txDir_ClientFldr & "EmailIn\"
tx4Msgbox = "txDir_ClientFldr = objFolder.Self.Path & '\' = " &
txDir_ClientFldr & vbCrLf _
& "txDir4Save = txDir_ClientFldr & 'EmailIn\' = " & txDir4Save
' MsgBox tx4Msgbox
'------------------------------------------------------------------------------
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myItem = myInspector.CurrentItem
'---------------------------------------------
'Save email item to Html file
'
With myItem
.BodyFormat = olFormatHTML
.Display
End With
sUsableDate = CStr(DatConvertedToMarcStyle(myItem.SentOn))
sPrefix = sUsableDate & "_" & myItem.SenderName
strname = sPrefix & "_" & myItem.Subject
iChar2bRemoved = InStr(3, strname, ":", vbTextCompare)
If iChar2bRemoved > 0 Then strname = Replace(strname, ":", "-_")
sFileFulnam = txDir4Save & strname & ".HTML"
sFileFulnam4Wmi = Replace(sFileFulnam, "\", "\\",
vbTextCompare)
If objFSO.FileExists(sFileFulnam) Then
MsgBox "The file exists! Insert a subroutine here."
End If
myItem.SaveAs sFileFulnam, olHTML
'--------------------------------------------
'Save email attachments in Dir under the Dir where EmailItem is
saved
'
Set myAttachments = myItem.Attachments
iAttachments = myAttachments.Count
iIteration01 = iAttachments
While iIteration01 > 0
aAttachFulName = txDir4Save & "Attachments\" & sPrefix & "_"
& _
myAttachments.item(iIteration01).DisplayName
aAttachFulName4Wmi = Replace(aAttachFulName, "\", "\\",
vbTextCompare)
iIteration01 = iIteration01 - 1
If objFSO.FileExists(aAttachFulName) Then
MsgBox "The file exists! Insert a subroutine here."
End If
myAttachments.item(1).SaveAsFile (aAttachFulName)
Wend
End If
End If
strPath = "explorer.exe /e, " & txDir4Save & "Attachments\"
Call Shell(strPath, vbNormalNoFocus)
End Sub

Marceepoo

2008-02-06 23:14:04 UTC

Permalink

Thank you. Thank you. Thank you.
Much appreciated.
Marceepoo

Post by Ken Slovak - [MVP - Outlook]
I'm not familiar with that API but if you also have VB installed on that
machine why not use the Windows Dialog Controls OCX (ComDlg32.ocx) instead,
it provides the standard File Open dialog for you. Even if you don't have VB
installed you can directly call the DLL that the OCX calls into.
Usage of ComDlg32.ocx is demonstrated at
http://www.vb-helper.com/howto_select_file.html. This link shows how to
directly use ComDlg32.DLL from VB code, the same would work for VBA code.
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm

Marceepoo

2008-02-14 19:19:00 UTC

Permalink

Hi Ken:

The referral you gave me led me to helpful urls from which I was able to add
some functionality to the shell.browsedialog in the Outlook macro below.

But I couldn't find ComDlg32.ocx on my computer.

3 questions:
a. Is there something similar that I could get from my Visual Studio 2008
installation, and use inside Outlook's vba?

b. The Outlook vba help revealed a "filedialog" object, but I couldnt
figure out how to use it, or where tofind any examples showing how to use it.

c. How can I determine whether an email item's attachment is (a) another
email item, or (b) a MS Word file, or (c) a pdf, or (d) a differnt type file
having some other unaticipated 3 character extension?

Here's the current version of my macro (designed to save emails and their
attachments to files, under a client's "Emailin" directory):.......

Option Explicit

Dim DestinationFolder As MAPIFolder

Private Sub testFunctionOrSub()
Dim filedialog As Object
Dim txFilename As String
txFilename = "K:\Data\Programs\Legasys\Templates\Letter.Dot"
txFilename = "C:\Apps\prncnfg.vbs"
txFilename = ""
' MsgBox FnChkIfFileExistsWmi(txFilename)
MsgBox fnDatMarcStyle01(Now)
End Sub

Public Function FnChkIfFileExistsWmi(txFilename)
'
Dim strComputer, txQuery, txTF As String
Dim objWMIService, colFiles As Object

strComputer = "."
' txFilename = "K:\\Data\\Programs\\Legasys\\Templates\\Letter.Dot"
txFilename = Replace(txFilename, "\", "\\")
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
txQuery = "Select * From CIM_Datafile Where Name = '" & txFilename & "'"
Set colFiles = objWMIService.ExecQuery(txQuery)
If colFiles.Count > 0 Then
txTF = "True"
Else
txTF = "False"
End If
FnChkIfFileExistsWmi = txTF
'
End Function

Public Sub FileExistsOverwriteOrNot(sfnFilFulname)
Dim myEmaiLItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim s4Msgbox, sChoice, sFileFulnam As String
s4Msgbox = "A file already has been saved at this address: " & vbCrLf &
vbCrLf _
& " '" & sfnFilFulname & "'" & vbCrLf & vbCrLf & "Do you want to
over-write" _
& "(ie. replace) it? Press 'Cancel' to exit the macro."
sChoice = MsgBox(s4Msgbox, vbYesNoCancel, "Save Email to file")

If sChoice = vbYes Then ' User chose Yes.
myEmaiLItem.SaveAs sFileFulnam, olHTML
ElseIf sChoice = vbNo Then ' User chose No.
'
ElseIf sChoice = vbCancel Then
'Question to investigate: how to control whether the 'exit sub' on
the next line
' will terminate this macro, or instead the macro that called this
macro.
Exit Sub ' Perform some action.
End If
End Sub

Public Function fnDatMarcStyle01(dtDatNow)
'
Dim txYear, txMonth, txDay, txHour, txMinute, txSecond, txAmPM As String
' Dim dtDatNow As Date
txYear = CStr(Year(dtDatNow))
If Month(dtDatNow) <= 9 Then txMonth = ("0" & CStr(Month(dtDatNow)))
Else txMonth = CStr(Month(dtDatNow))
If Day(dtDatNow) <= 9 Then txDay = ("0" & CStr(Day(dtDatNow))) Else
txDay = CStr(Day(dtDatNow))

If Hour(dtDatNow) > 12 Then txAmPM = "PM." Else txAmPM = "AM."
If Hour(dtDatNow) > 12 Then txHour = Hour(dtDatNow) - 1
If Hour(dtDatNow) <= 9 Then txHour = ("0" & CStr(Hour(dtDatNow))) Else
txHour = CStr(Hour(dtDatNow))
txHour = txAmPM & txHour

If Minute(dtDatNow) <= 9 Then txMinute = ("0" & CStr(Minute(dtDatNow)))
Else txMinute = CStr(Minute(dtDatNow))
If Second(dtDatNow) <= 9 Then txSecond = ("0" & CStr(Second(dtDatNow)))
Else txSecond = CStr(Second(dtDatNow))
dtDatNow = txYear & "-" & txMonth & "-" & txDay & "_" & txHour & "." &
txMinute & "." & txSecond
fnDatMarcStyle01 = dtDatNow
' MsgBox dtDatNow
End Function

Sub SaveEmailAndAttachmentS_07()
On Error Resume Next
'----------------------------
Dim myOlApp As Outlook.Application
Dim myInspector As Outlook.Inspector
Dim myEmaiLItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim iChar2bRemoved, iAttachments, iIteration01 As Integer
' Dim dlgDir4Save As Dialog
Dim sDirSaveEmailsHere, sDir_ClientFldr, sDirSaveWordFilsHere As String
Dim sName, sFileFulnam, sFileFulnam4Wmi, aAttachFulName, sAttachFileType
As String
Dim aAttachFulName4Wmi, sPathsPrefix, sUsableDate, s4Msgbox As String
Dim sPrefix, sPath, sChoice As String
Dim objFSO As FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")

Dim sEmlAtFileName, sEmlAtDisplayName, sEmlAtClass, sEmlAtIndex,
sEmlAtParent As String
Dim sEmlAtPathName, sEmlAtPosition, sEmlAtSession, sEmlAtType As String

' ToDos:
' convert to string
'do I really need the iIteration01, or is it hindering my prg?

sEmlAtFileName = ""
sEmlAtDisplayName = ""
sEmlAtClass = ""
sEmlAtIndex = ""
sEmlAtParent = ""
sEmlAtPathName = ""
sEmlAtPosition = ""
sEmlAtSession = ""
sEmlAtType = ""

Set myOlApp = CreateObject("Outlook.Application")
Set myInspector = myOlApp.ActiveInspector
iIteration01 = 0

If Not TypeName(myInspector) = "Nothing" Then

'----------------------------------------------------------------------------
' Dialog box browse for folder
'http://www.microsoft.com/communities/newsgroups/list/en-us/default.aspx?dg=microsoft.public.inetsdk.programming.scripting.vbscript&tid=2d0012e2-fb4c-4859-bfb9-87416515e912&cat=en_us_8e20817c-f87a-4b7a-a3b4-423a69908f60&lang=en&cr=us&p=1
'
' cannibalized from
http://www.microsoft.com/technet/scriptcenter/resources/qanda/jun05/hey0617.mspx
' and
http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_wqra.mspx?mfr=true
' and parameters of the dialog box may be found in...
' http://msdn2.microsoft.com/en-us/library/bb774096(VS.85).aspx
'
' I wish I could figure out
' (1) how to set a default folder (e.g. "K:\data")
' without limiting where the browser can find folders,
and
' (2) how to let the browseruse shortcuts to folders for faster
navigation
'
Dim objShell As Object
Dim ssfDESKTOP As Long
Dim objFolder
Dim objFolderItem
Dim strPath

Dim objJsys As Object
Set objJsys = CreateObject("JSSys3.ops")

' objJsys.SendTextCB (s4Msgbox)

Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0
Const OPTIONS = 0

'find constants at
http://blogs.msdn.com/gstemp/archive/2004/02/17/74868.aspx
Const BIF_returnonlyfsdirs = &H1
Const BIF_dontgobelowdomain = &H2
Const BIF_statustext = &H4
Const BIF_returnfsancestors = &H8
Const BIF_editbox = &H10
Const BIF_validate = &H20
Const BIF_browseforcomputer = &H1000
Const BIF_browseforprinter = &H2000
Const BIF_browseincludefiles = &H4000
Const cdlOFNExplorer = &H80000

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(MY_COMPUTER)
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Example",
BIF_editbox + BIF_browseincludefiles, ssfDESKTOP)
If (Not objFolder Is Nothing) Then
'Add code here.

sDir_ClientFldr = objFolder.Self.Path & "\"
sDirSaveEmailsHere = sDir_ClientFldr & "EmailIn\"
sDirSaveWordFilsHere = sDir_ClientFldr & "Word\"
s4Msgbox = "txDir_ClientFldr = objFolder.Self.Path & '\'
= " & sDir_ClientFldr & vbCrLf _
& "txDirSaveEmailsHere = sDir_ClientFldr &
'EmailIn\' = " & sDirSaveEmailsHere
'MsgBox s4Msgbox
End If

' sDir_ClientFldr = objFolder.Self.Path & "\"
sDir_ClientFldr = objFolder.Self.Path & "\"
sDirSaveEmailsHere = sDir_ClientFldr & "EmailIn\"
sDirSaveWordFilsHere = sDir_ClientFldr & "Word\"
s4Msgbox = "txDir_ClientFldr = objFolder.Self.Path & '\' = " &
sDir_ClientFldr & vbCrLf _
& "txDirSaveEmailsHere = sDir_ClientFldr & 'EmailIn\' = " &
sDirSaveEmailsHere
' MsgBox s4Msgbox

'------------------------------------------------------------------------------
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myEmaiLItem = myInspector.CurrentItem

'---------------------------------------------
'Save email item to Html file
'
With myEmaiLItem

.BodyFormat = olFormatHTML
' .HTMLBody = "<HTML><H2>The body of this message will appear
in HTML.</H2><BODY>Type the message text here. </BODY></HTML>"
.Display
End With

sUsableDate = CStr(myEmaiLItem.SentOn)
' MsgBox "CStr(Hour(myEmaiLItem.SentOn)) = " &
Hour(myEmaiLItem.SentOn)

sUsableDate = CStr(fnDatMarcStyle01(myEmaiLItem.SentOn))
' MsgBox "sUsableDate = " & sUsableDate
'MsgBox "myEmaiLItem.SentOn = " & myEmaiLItem.SentOn

sPrefix = sUsableDate & "_" & myEmaiLItem.SenderName
sName = sPrefix & "_" & myEmaiLItem.Subject

iChar2bRemoved = InStr(3, sName, ":", vbTextCompare)

If iChar2bRemoved > 0 Then sName = Replace(sName, ":", "-_")
sFileFulnam = sDirSaveEmailsHere & sName & ".HTML"

If FnChkIfFileExistsWmi(sFileFulnam) = "True" Then
Call FileExistsOverwriteOrNot(sFileFulnam)
End If

'--------------------------------------------
'Save email attachments in Dir under the Dir where EmailItem is
saved
'
Set myAttachments = myEmaiLItem.Attachments
iAttachments = myAttachments.Count
iIteration01 = iAttachments

s4Msgbox = ""
' s4Msgbox = vbide.
s4Msgbox = "iAttachments = myAttachments.Count = " & iAttachments
s4Msgbox = s4Msgbox & vbCrLf & ""

While iIteration01 >= 1

sEmlAtFileName =
CStr(myAttachments.Item(iIteration01).FileName)
sEmlAtDisplayName =
CStr(myAttachments.Item(iIteration01).DisplayName)
sEmlAtClass = CStr(myAttachments.Item(iIteration01).Class)
sEmlAtIndex = CStr(myAttachments.Item(iIteration01).Index)
sEmlAtParent = CStr(myAttachments.Item(iIteration01).Parent)
sEmlAtPathName =
CStr(myAttachments.Item(iIteration01).PathName)
sEmlAtPosition =
CStr(myAttachments.Item(iIteration01).Position)
sEmlAtSession = CStr(myAttachments.Item(iIteration01).Session)
sEmlAtType = CStr(myAttachments.Item(iIteration01).Type)

s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtFileName = " &
sEmlAtFileName
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtDisplayName = " &
sEmlAtDisplayName
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtClass = " & sEmlAtClass
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtIndex = " & sEmlAtIndex
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtParent = " &
sEmlAtParent
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtPathName = " &
sEmlAtPathName
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtPosition = " &
sEmlAtPosition
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtSession = " &
sEmlAtSession
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtType = " & sEmlAtType
s4Msgbox = s4Msgbox & vbCrLf &
TypeName(myAttachments.Item(iIteration01))

If TypeName(myAttachments.Item(iIteration01)) = "MailItem"
Then
s4Msgbox = s4Msgbox & vbCrLf & "CurrentItem is an email
item."
End If

s4Msgbox = s4Msgbox & vbCrLf & "-------------------------" &
vbCrLf

aAttachFulName = sDirSaveEmailsHere & "Attachments\" &
sPrefix & "_" & _
iIteration01 & "." &
myAttachments.Item(iIteration01).FileName

aAttachFulName4Wmi = Replace(aAttachFulName, "\", "\\",
vbTextCompare)

If iIteration01 >= 0 Then

' If objFSO.FileExists(aAttachFulName) Then
' MsgBox "The file exists! Insert a subroutine here."
' End If

sAttachFileType =
myAttachments.Item(iIteration01).Application
' MsgBox sAttachFileType & " - " & iIteration01
Select Case sAttachFileType
Case "Outlook"
aAttachFulName = aAttachFulName & ".msg"
Case Else
End Select
myAttachments.Item(iIteration01).SaveAsFile
(aAttachFulName)

iIteration01 = iIteration01 - 1

End If
Wend

End If
End If

sPath = "explorer.exe /e, " & sDirSaveEmailsHere & "Attachments\"
Call Shell(sPath, vbNormalNoFocus)
' MsgBox s4Msgbox

Set objFolder = Nothing
Set objShell = Nothing

Set objShell = Nothing

End Sub

Ken Slovak - [MVP - Outlook]

2008-02-14 20:22:17 UTC

Permalink

As I said before, if you have VB6 installed you have that ocx, if not then
you can directly use the comdlg32.dll, which is there on all Windows
systems. The link I provided told exactly how to use that dll from VB6 and
it would be identical for VBA code.

I have no idea what's in VS 2008 that you could use from VBA. I'm also not
going to plow through the ton of code you have below.

If this VBA code is running in the Outlook VBA project do not use
CreateObject to get an Outlook.Application object, use the intrinsic
Application object. Only use CreateObject if the code is not running in the
Outlook VBA.

Check for Attachment.Type, it tells if it's a file or an embedded object or
whatever. Also check for the file extension in the attachment's displayname
and filename properties. You will have to parse that yourself to see what it
is. Outlook doesn't set any special properties if it's a PDF or DOC or
whatever.
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm

Post by Marceepoo
The referral you gave me led me to helpful urls from which I was able to add
some functionality to the shell.browsedialog in the Outlook macro below.
But I couldn't find ComDlg32.ocx on my computer.
a. Is there something similar that I could get from my Visual Studio 2008
installation, and use inside Outlook's vba?
b. The Outlook vba help revealed a "filedialog" object, but I couldnt
figure out how to use it, or where tofind any examples showing how to use it.
c. How can I determine whether an email item's attachment is (a) another
email item, or (b) a MS Word file, or (c) a pdf, or (d) a differnt type file
having some other unaticipated 3 character extension?
Here's the current version of my macro (designed to save emails and their
attachments to files, under a client's "Emailin" directory):.......
Option Explicit
Dim DestinationFolder As MAPIFolder
Private Sub testFunctionOrSub()
Dim filedialog As Object
Dim txFilename As String
txFilename = "K:\Data\Programs\Legasys\Templates\Letter.Dot"
txFilename = "C:\Apps\prncnfg.vbs"
txFilename = ""
' MsgBox FnChkIfFileExistsWmi(txFilename)
MsgBox fnDatMarcStyle01(Now)
End Sub
Public Function FnChkIfFileExistsWmi(txFilename)
'
Dim strComputer, txQuery, txTF As String
Dim objWMIService, colFiles As Object
strComputer = "."
' txFilename = "K:\\Data\\Programs\\Legasys\\Templates\\Letter.Dot"
txFilename = Replace(txFilename, "\", "\\")
Set objWMIService = GetObject("winmgmts:\\" & strComputer &
"\root\cimv2")
txQuery = "Select * From CIM_Datafile Where Name = '" & txFilename & "'"
Set colFiles = objWMIService.ExecQuery(txQuery)
If colFiles.Count > 0 Then
txTF = "True"
Else
txTF = "False"
End If
FnChkIfFileExistsWmi = txTF
'
End Function
Public Sub FileExistsOverwriteOrNot(sfnFilFulname)
Dim myEmaiLItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim s4Msgbox, sChoice, sFileFulnam As String
s4Msgbox = "A file already has been saved at this address: " & vbCrLf &
vbCrLf _
& " '" & sfnFilFulname & "'" & vbCrLf & vbCrLf & "Do you want to
over-write" _
& "(ie. replace) it? Press 'Cancel' to exit the macro."
sChoice = MsgBox(s4Msgbox, vbYesNoCancel, "Save Email to file")
If sChoice = vbYes Then ' User chose Yes.
myEmaiLItem.SaveAs sFileFulnam, olHTML
ElseIf sChoice = vbNo Then ' User chose No.
'
ElseIf sChoice = vbCancel Then
'Question to investigate: how to control whether the 'exit sub' on
the next line
' will terminate this macro, or instead the macro that called this
macro.
Exit Sub ' Perform some action.
End If
End Sub
Public Function fnDatMarcStyle01(dtDatNow)
'
Dim txYear, txMonth, txDay, txHour, txMinute, txSecond, txAmPM As String
' Dim dtDatNow As Date
txYear = CStr(Year(dtDatNow))
If Month(dtDatNow) <= 9 Then txMonth = ("0" & CStr(Month(dtDatNow)))
Else txMonth = CStr(Month(dtDatNow))
If Day(dtDatNow) <= 9 Then txDay = ("0" & CStr(Day(dtDatNow))) Else
txDay = CStr(Day(dtDatNow))
If Hour(dtDatNow) > 12 Then txAmPM = "PM." Else txAmPM = "AM."
If Hour(dtDatNow) > 12 Then txHour = Hour(dtDatNow) - 1
If Hour(dtDatNow) <= 9 Then txHour = ("0" & CStr(Hour(dtDatNow))) Else
txHour = CStr(Hour(dtDatNow))
txHour = txAmPM & txHour
If Minute(dtDatNow) <= 9 Then txMinute = ("0" & CStr(Minute(dtDatNow)))
Else txMinute = CStr(Minute(dtDatNow))
If Second(dtDatNow) <= 9 Then txSecond = ("0" & CStr(Second(dtDatNow)))
Else txSecond = CStr(Second(dtDatNow))
dtDatNow = txYear & "-" & txMonth & "-" & txDay & "_" & txHour & "." &
txMinute & "." & txSecond
fnDatMarcStyle01 = dtDatNow
' MsgBox dtDatNow
End Function
Sub SaveEmailAndAttachmentS_07()
On Error Resume Next
'----------------------------
Dim myOlApp As Outlook.Application
Dim myInspector As Outlook.Inspector
Dim myEmaiLItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim iChar2bRemoved, iAttachments, iIteration01 As Integer
' Dim dlgDir4Save As Dialog
Dim sDirSaveEmailsHere, sDir_ClientFldr, sDirSaveWordFilsHere As String
Dim sName, sFileFulnam, sFileFulnam4Wmi, aAttachFulName,
sAttachFileType
As String
Dim aAttachFulName4Wmi, sPathsPrefix, sUsableDate, s4Msgbox As String
Dim sPrefix, sPath, sChoice As String
Dim objFSO As FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim sEmlAtFileName, sEmlAtDisplayName, sEmlAtClass, sEmlAtIndex,
sEmlAtParent As String
Dim sEmlAtPathName, sEmlAtPosition, sEmlAtSession, sEmlAtType As String
' convert to string
'do I really need the iIteration01, or is it hindering my prg?
sEmlAtFileName = ""
sEmlAtDisplayName = ""
sEmlAtClass = ""
sEmlAtIndex = ""
sEmlAtParent = ""
sEmlAtPathName = ""
sEmlAtPosition = ""
sEmlAtSession = ""
sEmlAtType = ""
Set myOlApp = CreateObject("Outlook.Application")
Set myInspector = myOlApp.ActiveInspector
iIteration01 = 0
If Not TypeName(myInspector) = "Nothing" Then
'----------------------------------------------------------------------------
' Dialog box browse for folder
'http://www.microsoft.com/communities/newsgroups/list/en-us/default.aspx?dg=microsoft.public.inetsdk.programming.scripting.vbscript&tid=2d0012e2-fb4c-4859-bfb9-87416515e912&cat=en_us_8e20817c-f87a-4b7a-a3b4-423a69908f60&lang=en&cr=us&p=1
'
' cannibalized from
http://www.microsoft.com/technet/scriptcenter/resources/qanda/jun05/hey0617.mspx
' and
http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_wqra.mspx?mfr=true
' and parameters of the dialog box may be found in...
' http://msdn2.microsoft.com/en-us/library/bb774096(VS.85).aspx
'
' I wish I could figure out
' (1) how to set a default folder (e.g. "K:\data")
' without limiting where the browser can find folders,
and
' (2) how to let the browseruse shortcuts to folders for faster
navigation
'
Dim objShell As Object
Dim ssfDESKTOP As Long
Dim objFolder
Dim objFolderItem
Dim strPath
Dim objJsys As Object
Set objJsys = CreateObject("JSSys3.ops")
' objJsys.SendTextCB (s4Msgbox)
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0
Const OPTIONS = 0
'find constants at
http://blogs.msdn.com/gstemp/archive/2004/02/17/74868.aspx
Const BIF_returnonlyfsdirs = &H1
Const BIF_dontgobelowdomain = &H2
Const BIF_statustext = &H4
Const BIF_returnfsancestors = &H8
Const BIF_editbox = &H10
Const BIF_validate = &H20
Const BIF_browseforcomputer = &H1000
Const BIF_browseforprinter = &H2000
Const BIF_browseincludefiles = &H4000
Const cdlOFNExplorer = &H80000
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(MY_COMPUTER)
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Example",
BIF_editbox + BIF_browseincludefiles, ssfDESKTOP)
If (Not objFolder Is Nothing) Then
'Add code here.
sDir_ClientFldr = objFolder.Self.Path & "\"
sDirSaveEmailsHere = sDir_ClientFldr & "EmailIn\"
sDirSaveWordFilsHere = sDir_ClientFldr & "Word\"
s4Msgbox = "txDir_ClientFldr = objFolder.Self.Path & '\'
= " & sDir_ClientFldr & vbCrLf _
& "txDirSaveEmailsHere = sDir_ClientFldr &
'EmailIn\' = " & sDirSaveEmailsHere
'MsgBox s4Msgbox
End If
' sDir_ClientFldr = objFolder.Self.Path & "\"
sDir_ClientFldr = objFolder.Self.Path & "\"
sDirSaveEmailsHere = sDir_ClientFldr & "EmailIn\"
sDirSaveWordFilsHere = sDir_ClientFldr & "Word\"
s4Msgbox = "txDir_ClientFldr = objFolder.Self.Path & '\' = " &
sDir_ClientFldr & vbCrLf _
& "txDirSaveEmailsHere = sDir_ClientFldr & 'EmailIn\' = " &
sDirSaveEmailsHere
' MsgBox s4Msgbox
'------------------------------------------------------------------------------
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myEmaiLItem = myInspector.CurrentItem
'---------------------------------------------
'Save email item to Html file
'
With myEmaiLItem
.BodyFormat = olFormatHTML
' .HTMLBody = "<HTML><H2>The body of this message will appear
in HTML.</H2><BODY>Type the message text here. </BODY></HTML>"
.Display
End With
sUsableDate = CStr(myEmaiLItem.SentOn)
' MsgBox "CStr(Hour(myEmaiLItem.SentOn)) = " &
Hour(myEmaiLItem.SentOn)
sUsableDate = CStr(fnDatMarcStyle01(myEmaiLItem.SentOn))
' MsgBox "sUsableDate = " & sUsableDate
'MsgBox "myEmaiLItem.SentOn = " & myEmaiLItem.SentOn
sPrefix = sUsableDate & "_" & myEmaiLItem.SenderName
sName = sPrefix & "_" & myEmaiLItem.Subject
iChar2bRemoved = InStr(3, sName, ":", vbTextCompare)
If iChar2bRemoved > 0 Then sName = Replace(sName, ":", "-_")
sFileFulnam = sDirSaveEmailsHere & sName & ".HTML"
If FnChkIfFileExistsWmi(sFileFulnam) = "True" Then
Call FileExistsOverwriteOrNot(sFileFulnam)
End If
'--------------------------------------------
'Save email attachments in Dir under the Dir where EmailItem is
saved
'
Set myAttachments = myEmaiLItem.Attachments
iAttachments = myAttachments.Count
iIteration01 = iAttachments
s4Msgbox = ""
' s4Msgbox = vbide.
s4Msgbox = "iAttachments = myAttachments.Count = " & iAttachments
s4Msgbox = s4Msgbox & vbCrLf & ""
While iIteration01 >= 1
sEmlAtFileName =
CStr(myAttachments.Item(iIteration01).FileName)
sEmlAtDisplayName =
CStr(myAttachments.Item(iIteration01).DisplayName)
sEmlAtClass = CStr(myAttachments.Item(iIteration01).Class)
sEmlAtIndex = CStr(myAttachments.Item(iIteration01).Index)
sEmlAtParent =
CStr(myAttachments.Item(iIteration01).Parent)
sEmlAtPathName =
CStr(myAttachments.Item(iIteration01).PathName)
sEmlAtPosition =
CStr(myAttachments.Item(iIteration01).Position)
sEmlAtSession =
CStr(myAttachments.Item(iIteration01).Session)
sEmlAtType = CStr(myAttachments.Item(iIteration01).Type)
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtFileName = " &
sEmlAtFileName
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtDisplayName = " &
sEmlAtDisplayName
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtClass = " & sEmlAtClass
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtIndex = " & sEmlAtIndex
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtParent = " &
sEmlAtParent
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtPathName = " &
sEmlAtPathName
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtPosition = " &
sEmlAtPosition
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtSession = " &
sEmlAtSession
s4Msgbox = s4Msgbox & vbCrLf & "sEmlAtType = " & sEmlAtType
s4Msgbox = s4Msgbox & vbCrLf &
TypeName(myAttachments.Item(iIteration01))
If TypeName(myAttachments.Item(iIteration01)) = "MailItem"
Then
s4Msgbox = s4Msgbox & vbCrLf & "CurrentItem is an email
item."
End If
s4Msgbox = s4Msgbox & vbCrLf & "-------------------------" &
vbCrLf
aAttachFulName = sDirSaveEmailsHere & "Attachments\" &
sPrefix & "_" & _
iIteration01 & "." &
myAttachments.Item(iIteration01).FileName
aAttachFulName4Wmi = Replace(aAttachFulName, "\", "\\",
vbTextCompare)
If iIteration01 >= 0 Then
' If objFSO.FileExists(aAttachFulName) Then
' MsgBox "The file exists! Insert a subroutine here."
' End If
sAttachFileType =
myAttachments.Item(iIteration01).Application
' MsgBox sAttachFileType & " - " & iIteration01
Select Case sAttachFileType
Case "Outlook"
aAttachFulName = aAttachFulName & ".msg"
Case Else
End Select
myAttachments.Item(iIteration01).SaveAsFile
(aAttachFulName)
iIteration01 = iIteration01 - 1
End If
Wend
End If
End If
sPath = "explorer.exe /e, " & sDirSaveEmailsHere & "Attachments\"
Call Shell(sPath, vbNormalNoFocus)
' MsgBox s4Msgbox
Set objFolder = Nothing
Set objShell = Nothing
Set objShell = Nothing
End Sub

Marceepoo

2008-02-15 18:08:01 UTC

Permalink

Dear Ken:

I wasted your time, and I apologize. I probably shouldn't have been trying
to do coding and posting questions, while carrying a fever and bronchitis.
Today, I readily found "ComDlg32.ocx". Yesterday I spent over an hunting for
it. (I must have been demented.) I

Thanks again for answering my questions. It means so much to the people
whom you help.
Gratefully, marceepoo

Post by Ken Slovak - [MVP - Outlook]
As I said before, if you have VB6 installed you have that ocx, if not then
you can directly use the comdlg32.dll, which is there on all Windows
systems. The link I provided told exactly how to use that dll from VB6 and
it would be identical for VBA code.
I have no idea what's in VS 2008 that you could use from VBA. I'm also not
going to plow through the ton of code you have below.
If this VBA code is running in the Outlook VBA project do not use
CreateObject to get an Outlook.Application object, use the intrinsic
Application object. Only use CreateObject if the code is not running in the
Outlook VBA.
Check for Attachment.Type, it tells if it's a file or an embedded object or
whatever. Also check for the file extension in the attachment's displayname
and filename properties. You will have to parse that yourself to see what it
is. Outlook doesn't set any special properties if it's a PDF or DOC or
whatever.
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm

Post by Marceepoo
The referral you gave me led me to helpful urls from which I was able to add
some functionality to the shell.browsedialog in the Outlook macro below.
But I couldn't find ComDlg32.ocx on my computer.
a. Is there something similar that I could get from my Visual Studio 2008
installation, and use inside Outlook's vba?
b. The Outlook vba help revealed a "filedialog" object, but I couldnt
figure out how to use it, or where tofind any examples showing how to use it.
c. How can I determine whether an email item's attachment is (a) another
email item, or (b) a MS Word file, or (c) a pdf, or (d) a differnt type file
having some other unaticipated 3 character extension?
Here's the current version of my macro (designed to save emails and their
attachments to files, under a client's "Emailin" directory):.......
Option Explicit
Dim DestinationFolder As MAPIFolder
Private Sub testFunctionOrSub()
Dim filedialog As Object
Dim txFilename As String
txFilename = "K:\Data\Programs\Legasys\Templates\Letter.Dot"
txFilename = "C:\Apps\prncnfg.vbs"
txFilename = ""
' MsgBox FnChkIfFileExistsWmi(txFilename)
MsgBox fnDatMarcStyle01(Now)
End Sub
Public Function FnChkIfFileExistsWmi(txFilename)
'
Dim strComputer, txQuery, txTF As String
Dim objWMIService, colFiles As Object
strComputer = "."
' txFilename = "K:\\Data\\Programs\\Legasys\\Templates\\Letter.Dot"
txFilename = Replace(txFilename, "\", "\\")
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
txQuery = "Select * From CIM_Datafile Where Name = '" & txFilename & "'"
Set colFiles = objWMIService.ExecQuery(txQuery)
If colFiles.Count > 0 Then
txTF = "True"
Else
txTF = "False"
End If
FnChkIfFileExistsWmi = txTF
'
End Function
Public Sub FileExistsOverwriteOrNot(sfnFilFulname)
Dim myEmaiLItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim s4Msgbox, sChoice, sFileFulnam As String
s4Msgbox = "A file already has been saved at this address: " & vbCrLf &
vbCrLf _
& " '" & sfnFilFulname & "'" & vbCrLf & vbCrLf & "Do you want to
over-write" _
& "(ie. replace) it? Press 'Cancel' to exit the macro."
sChoice = MsgBox(s4Msgbox, vbYesNoCancel, "Save Email to file")
If sChoice = vbYes Then ' User chose Yes.
myEmaiLItem.SaveAs sFileFulnam, olHTML
ElseIf sChoice = vbNo Then ' User chose No.
'
ElseIf sChoice = vbCancel Then
'Question to investigate: how to control whether the 'exit sub' on
the next line
' will terminate this macro, or instead the macro that called this
macro.
Exit Sub ' Perform some action.
End If
End Sub
Public Function fnDatMarcStyle01(dtDatNow)
'
Dim txYear, txMonth, txDay, txHour, txMinute, txSecond, txAmPM As String
' Dim dtDatNow As Date
txYear = CStr(Year(dtDatNow))
If Month(dtDatNow) <= 9 Then txMonth = ("0" & CStr(Month(dtDatNow)))
Else txMonth = CStr(Month(dtDatNow))
If Day(dtDatNow) <= 9 Then txDay = ("0" & CStr(Day(dtDatNow))) Else
txDay = CStr(Day(dtDatNow))
If Hour(dtDatNow) > 12 Then txAmPM = "PM." Else txAmPM = "AM."
If Hour(dtDatNow) > 12 Then txHour = Hour(dtDatNow) - 1
If Hour(dtDatNow) <= 9 Then txHour = ("0" & CStr(Hour(dtDatNow))) Else
txHour = CStr(Hour(dtDatNow))
txHour = txAmPM & txHour
If Minute(dtDatNow) <= 9 Then txMinute = ("0" & CStr(Minute(dtDatNow)))
Else txMinute = CStr(Minute(dtDatNow))
If Second(dtDatNow) <= 9 Then txSecond = ("0" & CStr(Second(dtDatNow)))
Else txSecond = CStr(Second(dtDatNow))
dtDatNow = txYear & "-" & txMonth & "-" & txDay & "_" & txHour & "." &
txMinute & "." & txSecond
fnDatMarcStyle01 = dtDatNow
' MsgBox dtDatNow
End Function
Sub SaveEmailAndAttachmentS_07()
On Error Resume Next
'----------------------------
Dim myOlApp As Outlook.Application
Dim myInspector As Outlook.Inspector
Dim myEmaiLItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim iChar2bRemoved, iAttachments, iIteration01 As Integer
' Dim dlgDir4Save As Dialog
Dim sDirSaveEmailsHere, sDir_ClientFldr, sDirSaveWordFilsHere As String
Dim sName, sFileFulnam, sFileFulnam4Wmi, aAttachFulName,
sAttachFileType
As String
Dim aAttachFulName4Wmi, sPathsPrefix, sUsableDate, s4Msgbox As String
Dim sPrefix, sPath, sChoice As String
Dim objFSO As FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim sEmlAtFileName, sEmlAtDisplayName, sEmlAtClass, sEmlAtIndex,
sEmlAtParent As String
Dim sEmlAtPathName, sEmlAtPosition, sEmlAtSession, sEmlAtType As String
' convert to string
'do I really need the iIteration01, or is it hindering my prg?
sEmlAtFileName = ""
sEmlAtDisplayName = ""
sEmlAtClass = ""
sEmlAtIndex = ""
sEmlAtParent = ""
sEmlAtPathName = ""
sEmlAtPosition = ""
sEmlAtSession = ""
sEmlAtType = ""
Set myOlApp = CreateObject("Outlook.Application")
Set myInspector = myOlApp.ActiveInspector
iIteration01 = 0
If Not TypeName(myInspector) = "Nothing" Then
'----------------------------------------------------------------------------
' Dialog box browse for folder
'http://www.microsoft.com/communities/newsgroups/list/en-us/default.aspx?dg=microsoft.public.inetsdk.programming.scripting.vbscript&tid=2d0012e2-fb4c-4859-bfb9-87416515e912&cat=en_us_8e20817c-f87a-4b7a-a3b4-423a69908f60&lang=en&cr=us&p=1
'
' cannibalized from
http://www.microsoft.com/technet/scriptcenter/resources/qanda/jun05/hey0617.mspx
' and
http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_wqra.mspx?mfr=true
' and parameters of the dialog box may be found in...
' http://msdn2.microsoft.com/en-us/library/bb774096(VS.85).aspx
'
' I wish I could figure out
' (1) how to set a default folder (e.g. "K:\data")
' without limiting where the browser can find folders,
and
' (2) how to let the browseruse shortcuts to folders for faster
navigation
'
Dim objShell As Object
Dim ssfDESKTOP As Long
Dim objFolder
Dim objFolderItem
Dim strPath
Dim objJsys As Object
Set objJsys = CreateObject("JSSys3.ops")
' objJsys.SendTextCB (s4Msgbox)
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0
Const OPTIONS = 0
'find constants at
http://blogs.msdn.com/gstemp/archive/2004/02/17/74868.aspx
Const BIF_returnonlyfsdirs = &H1
Const BIF_dontgobelowdomain = &H2
Const BIF_statustext = &H4
Const BIF_returnfsancestors = &H8
Const BIF_editbox = &H10
Const BIF_validate = &H20
Const BIF_browseforcomputer = &H1000
Const BIF_browseforprinter = &H2000
Const BIF_browseincludefiles = &H4000
Const cdlOFNExplorer = &H80000
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(MY_COMPUTER)
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Example",
BIF_editbox + BIF_browseincludefiles, ssfDESKTOP)
If (Not objFolder Is Nothing) Then
'Add code here.
sDir_ClientFldr = objFolder.Self.Path & "\"
sDirSaveEmailsHere = sDir_ClientFldr & "EmailIn\"
sDirSaveWordFilsHere = sDir_ClientFldr & "Word\"
s4Msgbox = "txDir_ClientFldr = objFolder.Self.Path & '\'
= " & sDir_ClientFldr & vbCrLf _
& "txDirSaveEmailsHere = sDir_ClientFldr &
'EmailIn\' = " & sDirSaveEmailsHere
'MsgBox s4Msgbox
End If
' sDir_ClientFldr = objFolder.Self.Path & "\"
sDir_ClientFldr = objFolder.Self.Path & "\"
sDirSaveEmailsHere = sDir_ClientFldr & "EmailIn\"
sDirSaveWordFilsHere = sDir_ClientFldr & "Word\"
s4Msgbox = "txDir_ClientFldr = objFolder.Self.Path & '\' = " &
sDir_ClientFldr & vbCrLf _
& "txDirSaveEmailsHere = sDir_ClientFldr & 'EmailIn\' = " &
sDirSaveEmailsHere
' MsgBox s4Msgbox
'------------------------------------------------------------------------------
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myEmaiLItem = myInspector.CurrentItem
'---------------------------------------------
'Save email item to Html file
'
With myEmaiLItem
.BodyFormat = olFormatHTML
' .HTMLBody = "<HTML><H2>The body of this message will appear
in HTML.</H2><BODY>Type the message text here. </BODY></HTML>"
.Display
End With
sUsableDate = CStr(myEmaiLItem.SentOn)
' MsgBox "CStr(Hour(myEmaiLItem.SentOn)) = " &
Hour(myEmaiLItem.SentOn)
sUsableDate = CStr(fnDatMarcStyle01(myEmaiLItem.SentOn))
' MsgBox "sUsableDate = " & sUsableDate
'MsgBox "myEmaiLItem.SentOn = " & myEmaiLItem.SentOn
sPrefix = sUsableDate & "_" & myEmaiLItem.SenderName
sName = sPrefix & "_" & myEmaiLItem.Subject
iChar2bRemoved = InStr(3, sName, ":", vbTextCompare)

Marceepoo

2008-02-25 03:24:00 UTC

Permalink

Dear Ken:

I feel like a bad penny that never goes away. I did spend several hours
trying before bothering you again with my ignorance. (I'm still a newbie at
this stuff.)

I created a form and put the commondialog control on it, and I inserted the
following code that I copied from http://support.microsoft.com/kb/161286

When I click on the command button, I get this error message:
"Compile error. Variable not defined."
The debugger highlights the characters: "App" which appear on the 7th line.
I don't know what to do to fix that, or where to go to learn what I need to
learn to understand the code in KB161286. Any suggestions?
Thanks again for your help. I wish I could return the favor.
marceepoo

Here's the code:

Option Explicit

'http://support.microsoft.com/kb/161286
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Sub btnCmd01_Click()
'
'http://support.microsoft.com/kb/161286
'
Dim frmComDlg01 As Form
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = frmComDlg01.HWnd
OpenFile.hInstance = App.hInstance
sFilter = "Batch Files (*.bat)" & Chr(0) & "*.BAT" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = "C:\"
OpenFile.lpstrTitle = "Use the Comdlg API not the OCX"
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
MsgBox "The User pressed the Cancel Button"
Else
MsgBox "The user Chose " & Trim(OpenFile.lpstrFile)
End If
End Sub

Ken Slovak - [MVP - Outlook]

2008-02-25 14:12:01 UTC

Permalink

What kind of form is that? Is it a VBA UserForm or what?

hInstance is a value for the instance handle for that instance of your form,
just as hWnd is the window handle for that window when it opens. Both are
transient values that are only valid for that invocation of your form.

You can just omit the line for setting the hInstance if you aren't using it.
VBA UserForms don't provide a hInstance property (nor a hWnd property). If
formComDlgo1.hWnd doesn't exist from a UserForm just set that value to 0, it
will denote that no window owns the Comdlg32 window when it's displayed.
--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm

Post by Marceepoo
I feel like a bad penny that never goes away. I did spend several hours
trying before bothering you again with my ignorance. (I'm still a newbie at
this stuff.)
I created a form and put the commondialog control on it, and I inserted the
following code that I copied from http://support.microsoft.com/kb/161286
"Compile error. Variable not defined."
The debugger highlights the characters: "App" which appear on the 7th line.
I don't know what to do to fix that, or where to go to learn what I need to
learn to understand the code in KB161286. Any suggestions?
Thanks again for your help. I wish I could return the favor.
marceepoo
Option Explicit
'http://support.microsoft.com/kb/161286
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Sub btnCmd01_Click()
'
'http://support.microsoft.com/kb/161286
'
Dim frmComDlg01 As Form
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = frmComDlg01.HWnd
OpenFile.hInstance = App.hInstance
sFilter = "Batch Files (*.bat)" & Chr(0) & "*.BAT" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = "C:\"
OpenFile.lpstrTitle = "Use the Comdlg API not the OCX"
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
MsgBox "The User pressed the Cancel Button"
Else
MsgBox "The user Chose " & Trim(OpenFile.lpstrFile)
End If
End Sub