|
|
|
date: Tue, 5 Feb 2008 16:22:32 -0800,
group: microsoft.public.office.developer.outlook.vba
back
Re: objShell.BrowseForFolder dialog - how to use file shortcuts
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 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
"Ken Slovak - [MVP - Outlook]" wrote:
> 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
>
>
> "Marceepoo" <36c53a08-2073470544@news.postalias> wrote in message
> news:B2C8BE2B-FDC9-4A01-A3BF-F17DDD69E650@microsoft.com...
> > 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
>
>
date: Wed, 6 Feb 2008 10:16:01 -0800
author: Marceepoo alias
Re: objShell.BrowseForFolder dialog - how to use file shortcuts
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" <36c53a08-2073470544@news.postalias> wrote in message
news:0653715E-6BFD-41CC-AA71-1802433C6BC9@microsoft.com...
>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 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
date: Wed, 6 Feb 2008 13:52:03 -0500
author: Ken Slovak - [MVP - Outlook]
Re: objShell.BrowseForFolder dialog - how to use file shortcuts
Thank you. Thank you. Thank you.
Much appreciated.
Marceepoo
"Ken Slovak - [MVP - Outlook]" wrote:
> 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" <36c53a08-2073470544@news.postalias> wrote in message
> news:0653715E-6BFD-41CC-AA71-1802433C6BC9@microsoft.com...
> >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 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
>
>
date: Wed, 6 Feb 2008 15:14:04 -0800
author: Marceepoo alias
Re: objShell.BrowseForFolder dialog - how to use file shortcuts
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]" wrote:
> 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" <36c53a08-2073470544@news.postalias> wrote in message
> news:0653715E-6BFD-41CC-AA71-1802433C6BC9@microsoft.com...
> >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 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
>
>
date: Thu, 14 Feb 2008 11:19:00 -0800
author: Marceepoo alias
Re: objShell.BrowseForFolder dialog - how to use file shortcuts
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
"Marceepoo" <36c53a08-2073470544@news.postalias> wrote in message
news:75D6F874-C9B7-4262-879D-1A17CC7DD773@microsoft.com...
> 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
date: Thu, 14 Feb 2008 15:22:17 -0500
author: Ken Slovak - [MVP - Outlook]
Re: objShell.BrowseForFolder dialog - how to use file shortcuts
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
"Ken Slovak - [MVP - Outlook]" wrote:
> 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
>
>
> "Marceepoo" <36c53a08-2073470544@news.postalias> wrote in message
> news:75D6F874-C9B7-4262-879D-1A17CC7DD773@microsoft.com...
> > 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)
> >
date: Fri, 15 Feb 2008 10:08:01 -0800
author: Marceepoo alias
Re: objShell.BrowseForFolder dialog - how to use file shortcuts
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]" wrote:
> 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" <36c53a08-2073470544@news.postalias> wrote in message
> news:0653715E-6BFD-41CC-AA71-1802433C6BC9@microsoft.com...
> >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 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
>
>
date: Sun, 24 Feb 2008 19:24:00 -0800
author: Marceepoo alias
|
|
