vba Outlook Saveas

Question

Bonsoir

Je voudrais pouvoir sauvegarder des pièces jointes dans un dossier choisi par l'utilisateur, pièce par pièce.
La collection Dialogs n'existe pas dans Outlook.
Il me semble qu'on pourrait le faire avec PickerDialog.
Seulement l'aide est indigente et n'explique pas du tout comment ça fonctionne.
Le seul exemple concerne une fenêtre de recherche de personnes.
Quelqu'un a-t-il un mode d'emploi de cette collection ?
A défaut, comment faire ouvrir une fenêtre de choix de dossier avec le nom du fichier ?

merci

Answer 1

Bonsoir

Si personne n'a d'idée, je me contenterais de cette solution dégradée, si elle existe en vba Outlook :

comment faire ouvrir une fenêtre de choix de dossier

merci.

Answer 2

Bonjour,

 

Je sais le faire depuis Excel. Est-ce que ça peut t'aider ? Tu peux

peut-être ouvrir une instance Excel qui exécuterait la macro ?

 

Daniel

 

 

 

Answer 3

Bonjour Geo Le Tourangeau,

Une solution est d'utiliser SHBrowseForFolder

Code VB6 trouvé ICI adapté à VBA : principalement recherche du handle du UserForm qui devient propriétaire de la fenêtre de recherche. Fonctionnel sous Outlook, Excel, etc.

Code du UserForm :

Option Explicit

' Spécifique à VBA, le UserForm n'a pas de Handle - J93
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private UFhWnd As Long ' J93

Private Sub UserForm_Initialize()
   CommandButton1.Caption = "Browse using folder name"
   CommandButton2.Caption = "Browse using folder pidl"
   
   'a default start point
   TextBox1.Text = Environ("USERPROFILE") ' J93
End Sub

Private Sub CommandButton1_Click()
   Dim spath As String
  
  'the path used in the Browse function
  'must be correctly formatted depending
  'on whether the path is a drive, a
  'folder, or "".
   spath = FixPath(TextBox1.Text)
   
  'call the function, returning the path
  'selected (or "" if cancelled)
   TextBox2.Text = BrowseForFolderByPath(spath)
End Sub

Private Sub CommandButton2_Click()
   Dim spath As String
   
   spath = FixPath(TextBox1.Text)
   TextBox2.Text = BrowseForFolderByPIDL(spath)
End Sub

Private Function BrowseForFolderByPath(sSelPath As String) As String
   Dim BI As BROWSEINFO
   Dim pidl As Long
   Dim lpSelPath As Long
   Dim spath As String * MAX_PATH
   
   With BI
      'recuperer le Handle de l'Usf : Daniel Klann - J93
      Dim strFormClassName As String

      If Val(Application.Version) < 9 Then 'Excel 2000
         strFormClassName = "ThunderXFrame"
      Else
         strFormClassName = "ThunderDFrame" 'Excel 2000/2002
      End If
    
      UFhWnd = FindWindow(strFormClassName, "UserForm1") 'le Handle de la fenetre

      .hOwner = UFhWnd
      .pidlRoot = 0
      .lpszTitle = "Pre-selecting folder using the folder's string."
      .lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
    
      lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
      CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
      .lParam = lpSelPath
   End With
    
   pidl = SHBrowseForFolder(BI)
   If pidl Then
      If SHGetPathFromIDList(pidl, spath) Then
        BrowseForFolderByPath = Left$(spath, InStr(spath, vbNullChar) - 1)
      Else
        BrowseForFolderByPath = ""
      End If
      
      Call CoTaskMemFree(pidl)
   Else
      BrowseForFolderByPath = ""
   End If
   Call LocalFree(lpSelPath)
End Function

Private Function BrowseForFolderByPIDL(sSelPath As String) As String
   Dim BI As BROWSEINFO
   Dim pidl As Long
   Dim spath As String * MAX_PATH
     
   With BI
      'recuperer le Handle de l'Usf : Daniel Klann - J93
      Dim strFormClassName As String

      If Val(Application.Version) < 9 Then 'Excel 2000
         strFormClassName = "ThunderXFrame"
      Else
         strFormClassName = "ThunderDFrame" 'Excel 2000/2002
      End If
    
      UFhWnd = FindWindow(strFormClassName, "UserForm1") 'le Handle de la fenetre
      
      .hOwner = UFhWnd
      .pidlRoot = 0
      .lpszTitle = "Pre-selecting a folder using the folder's pidl."
      .lpfn = FARPROC(AddressOf BrowseCallbackProc)
      .lParam = GetPIDLFromPath(sSelPath)
   End With
  
   pidl = SHBrowseForFolder(BI)
   If pidl Then
      If SHGetPathFromIDList(pidl, spath) Then
         BrowseForFolderByPIDL = Left$(spath, InStr(spath, vbNullChar) - 1)
      Else
         BrowseForFolderByPIDL = ""
      End If
     
     'free the pidl from SHBrowseForFolder call
      Call CoTaskMemFree(pidl)
   Else
      BrowseForFolderByPIDL = ""
   End If
  
   'free the pidl (lparam) from GetPIDLFromPath call
   Call CoTaskMemFree(BI.lParam)
End Function

Private Function GetPIDLFromPath(spath As String) As Long

  'return the pidl to the path supplied by calling the
  'undocumented API #162 (our name for this undocumented
  'function is "SHSimpleIDListFromPath").
  'This function is necessary as, unlike documented APIs,
  'the API is not implemented in 'A' or 'W' versions.

   If IsWinNT() Then
      GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(spath, vbUnicode))
   Else
      GetPIDLFromPath = SHSimpleIDListFromPath(spath)
   End If
End Function


Private Function IsWinNT() As Boolean
   #If Win32 Then
      Dim OSV As OSVERSIONINFO
   
      OSV.OSVSize = Len(OSV)
      'API returns 1 if a successful call
      If GetVersionEx(OSV) = 1 Then
   
        'PlatformId contains a value representing
        'the OS; if VER_PLATFORM_WIN32_NT,
        'return true
         IsWinNT = OSV.PlatformID = VER_PLATFORM_WIN32_NT
      End If
   #End If
End Function

Private Function IsValidDrive(spath As String) As Boolean
   Dim buff As String
   Dim nBuffsize As Long
   
  'Call the API with a buffer size of 0.
  'The call fails, and the required size
  'is returned as the result.
   nBuffsize = GetLogicalDriveStrings(0&, buff)

  'pad a buffer to hold the results
   buff = Space$(nBuffsize)
   nBuffsize = Len(buff)
   
  'and call again
   If GetLogicalDriveStrings(nBuffsize, buff) Then
     'if the drive letter passed is in
     'the returned logical drive string,
     'return True.
      IsValidDrive = InStr(1, buff, spath, vbTextCompare) > 0
   
   End If
End Function

Private Function FixPath(spath As String) As String

  'The Browse callback requires the path string
  'in a specific format - trailing slash if a
  'drive only, or minus a trailing slash if a
  'file system path. This routine assures the
  'string is formatted correctly.
  '
  'In addition, because the calls to LocalAlloc
  'requires a valid path for the call to succeed,
  'the path defaults to C:\ if the passed string
  'is empty.
  
  'Test 1: check for empty string. Since
  'we're setting it we can assure it is
  'formatted correctly, so can bail.
   If Len(spath) = 0 Then
      FixPath = "C:\"
      Exit Function
   End If
   
  'Test 2: is path a valid drive?
  'If this far we did not set the path,
  'so need further tests. Here we ensure
  'the path is properly terminated with
  'a trailing slash as needed.
  '
  'Drives alone require the trailing slash;
  'file system paths must have it removed.
   If IsValidDrive(spath) Then
      
     'IsValidDrive only determines if the
     'path provided is contained in
     'GetLogicalDriveStrings. Since
     'IsValidDrive() will return True
     'if either C: or C:\ is passed, we
     'need to ensure the string is formatted
     'with the trailing slash.
      FixPath = QualifyPath(spath)
   Else
     'The string passed was not a drive, so
     'assume it's a path and ensure it does
     'not have a trailing space.
      FixPath = UnqualifyPath(spath)
   End If
End Function

Private Function QualifyPath(spath As String) As String
   If Len(spath) > 0 Then
 
      If Right$(spath, 1) <> "\" Then
         QualifyPath = spath & "\"
      Else
         QualifyPath = spath
      End If
   Else
      QualifyPath = ""
   End If
End Function

Private Function UnqualifyPath(spath As String) As String
  'Qualifying a path involves assuring that its format
  'is valid, including a trailing slash, ready for a
  'filename. Since SHBrowseForFolder will not pre-select
  'the path if it contains the trailing slash, it must be
  'removed, hence 'unqualifying' the path.
   If Len(spath) > 0 Then
      If Right$(spath, 1) = "\" Then
         UnqualifyPath = Left$(spath, Len(spath) - 1)
         Exit Function
      End If
   End If
   UnqualifyPath = spath
End Function

Code du Module (non modifié) :

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'common to both methods
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Public Declare Function SHBrowseForFolder Lib "shell32" _
   Alias "SHBrowseForFolderA" _
   (lpBrowseInfo As BROWSEINFO) As Long

Public Declare Function SHGetPathFromIDList Lib "shell32" _
   Alias "SHGetPathFromIDListA" _
   (ByVal pidl As Long, _
   ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

Public Declare Function SendMessage Lib "User32" _
   Alias "SendMessageA" _
   (ByVal hWnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long
   
Public Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
   (pDest As Any, _
    pSource As Any, _
    ByVal dwLength As Long)
    
Public Const MAX_PATH As Long = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1

'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.

'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)

'If the lParam  parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)

'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
   

'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib _
   "shell32" Alias "#162" _
   (ByVal szPath As String) As Long


'specific to the STRING method
Public Declare Function LocalAlloc Lib "kernel32" _
   (ByVal uFlags As Long, _
    ByVal uBytes As Long) As Long
    
Public Declare Function LocalFree Lib "kernel32" _
   (ByVal hMem As Long) As Long

Public Declare Function lstrcpyA Lib "kernel32" _
   (lpString1 As Any, lpString2 As Any) As Long

Public Declare Function lstrlenA Lib "kernel32" _
   (lpString As Any) As Long

Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
  OSVSize         As Long
  dwVerMajor      As Long
  dwVerMinor      As Long
  dwBuildNumber   As Long
  PlatformID      As Long
  szCSDVersion    As String * 128
End Type
        
Public Const VER_PLATFORM_WIN32_NT = 2

Public Declare Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
  (lpVersionInformation As OSVERSIONINFO) As Long
  
Public Declare Function GetLogicalDriveStrings Lib "kernel32" _
   Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, _
   ByVal lpBuffer As String) As Long



Public Function BrowseCallbackProcStr(ByVal hWnd As Long, _
                                      ByVal uMsg As Long, _
                                      ByVal lParam As Long, _
                                      ByVal lpData As Long) As Long
                                       
  'Callback for the Browse STRING method.
 
  'On initialization, set the dialog's
  'pre-selected folder from the pointer
  'to the path allocated as bi.lParam,
  'passed back to the callback as lpData param.
 
   Select Case uMsg
      Case BFFM_INITIALIZED
      
         Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
                          1&, ByVal lpData)
                          
         Case Else:
         
   End Select
          
End Function
          

Public Function BrowseCallbackProc(ByVal hWnd As Long, _
                                   ByVal uMsg As Long, _
                                   ByVal lParam As Long, _
                                   ByVal lpData As Long) As Long
 
  'Callback for the Browse PIDL method.
 
  'On initialization, set the dialog's
  'pre-selected folder using the pidl
  'set as the bi.lParam, and passed back
  'to the callback as lpData param.
   Select Case uMsg
      Case BFFM_INITIALIZED
      
         Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
                          0&, ByVal lpData)
                          
         Case Else:
         
   End Select

End Function


Public Function FARPROC(pfn As Long) As Long
  
  'A dummy procedure that receives and returns
  'the value of the AddressOf operator.
 
  'This workaround is needed as you can't
  'assign AddressOf directly to a member of a
  'user-defined type, but you can assign it
  'to another long and use that instead!
  FARPROC = pfn

End Function

---

Cordialement, Jacques

Answer 4

Je sais le faire depuis Excel. Est-ce que ça peut t'aider ? Tu peux peut-être ouvrir une instance Excel qui exécuterait la macro ?

merci Daniel, je sais aussi le faire en Word, je suis donc passé par là, mais je trouve stupide d'ouvrir un Word ou un Excel uniquement pour ça.
Et le jour où ça va se planter on va se retrouver avec des instances de Word ou Excel et on se demandera d'où elles viennent.

Bonne journée.

Answer 5

Hou la la !
Et dire que ça fait deux lignes en vba Word ou Excel.

Je regarde ça.

merci Jacques

Answer 6

Bonjour Geo

Avez-vous des nouvelles pour nous?

Merci

Cordialement,

---

Aurel BERA, Microsoft
Microsoft propose ce service gratuitement, dans le but d'aider les utilisateurs et d'élargir les connaissances générales liées aux produits et technologies Microsoft. Ce contenu est fourni "tel quel" et il n'implique aucune responsabilité de la part de Microsoft.