Microsoft Office. Outlook Add-in und Add-on Software.

 

 

 

 

 

 VBA; GetFolder

Das folgende Script wählt einen Ordner aus und speichert die Auswahl in der Regisry ab. Jedesmal wenn wir einen Ordner für unserer Scripts benötigen, schreiben wir einfach

 

set folder = GetFolder("MyFolder",false,true)

 

Wurde schon einmal ein Ordner mit der Bezeichnung MyFolder ausgewählt, wird dieser geöffnet und zurückgegeben, wurde noch keiner ausgewählt, erscheint eine Auswahl, welche hinterher gleich in der Registry gespeichert wird. Beim nächsten Aufruf wird dann der Ordner ohne Dialog geöffnet.

 

Der zweite Paramter erzwingt die Abfrage. In einem Einstellungsdialog schreiben wir

 

set folder = GetFolder("MyFolder",true,false)

 

Der Dritte Parameter unterdrückt die Abfrage "Wählen Sie einen Ordner für MyFolder" aus, wenn das Script aus einem Dialog aufgerufen wird, weiss der Anwender, welcher Ordner es ist, wenn keine Konfiguration vorliegt, wird er darauf hingewiesen, was ausgesucht werden soll.

 

shared Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
shared Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
shared Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
shared Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
shared Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
shared Const ERROR_SUCCESS = 0&
shared Const HKEY_CURRENT_USER = &H80000001
shared Const REG_SZ = 1 ' Unicode nul terminated string

Const FolderRegKey = "Software\MyApp"


' Gets a folder from the registry
' If this folder is not defined in the registry, we define it and store it
' input:
' Name Name of the folder as it is identified in the Registry
' ask Always Ask for this folder
' global FolderRegKey: Root for the registry to search in
' output
' The folder or nothing


shared Function GetFolder(Name As String, Ask As Boolean, prompt As Boolean) As MAPIFolder
  Dim key As Long
  Dim hr As Long
  Dim eid As String
  Dim seid As String
  Dim ns As NameSpace
  Dim len1 As Long
  Dim typ As Long
  Dim p As Long
  Dim folder As MAPIFolder
 

  Set ns = Outlook.Application.GetNamespace("MAPI")
  hr = RegOpenKey(HKY_CURRENT_USER, FolderRegKey, key)
  If hr <> ERROR_SUCCESS Then hr = RegOpenKey(HKEY_CURRENT_USER, "\" & FolderRegKey, key)
  If hr <> ERROR_SUCCESS Then hr = RegCreateKey(HKEY_CURRENT_USER, FolderRegKey, key)
  If hr <> ERROR_SUCCESS Then hr = RegCreateKey(HKEY_CURRENT_USER, "\" & FolderRegKey, key)
  If hr = ERROR_SUCCESS Then
   ' Try to read the registry key, which contains the entry id of the folder
        If Not Ask Then
            eid = Space$(2000)
            len1 = Len(eid)
            hr = RegQueryValueEx(key, Name, 0, typ, ByVal eid, len1)
            If hr = ERROR_SUCCESS Then eid = Left(eid, len1 - 1)
        Else
           hr = ERROR_SUCESS + 1 ' Give any error message when user asks us to display dialog
        End If

    ' Try to open the folder
    If hr = ERROR_SUCCESS Then
       p = InStr(1, eid, ":")
       If p <> 0 Then
       seid = Mid(eid, p + 1)
       eid = Left(eid, p - 1)
    End If
        Set folder = ns.GetFolderFromID(eid, seid)
    End If

    ' Either the registry key was not stored or opening has failed, ask the user
    If folder Is Nothing Then
    If prompt Then
       MsgBox "Select folder for " & Name
    End If
    Set folder = ns.PickFolder
    eid = folder.EntryID & ":" & folder.StoreID
    hr = RegSetValueEx(key, Name, 0, REG_SZ, ByVal eid, Len(eid))
    If hr <> ERROR_SUCCESS Then
       MsgBox "Sorry, can not write Registry value " & Name
    End If
  End If
  RegCloseKey key

   End If
   Set GetFolder = folder
End Function