Const BIF_RETURNONLYFSDIRS = 1
Const BIF_DONTGOBELOWDOMAIN = 2
Const MAX_PATH = 260

in declarations put this

Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpbi As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (Byval pidList As Long, Byval lpBuffer As String) As Long
Declare Function FindWindow95 Lib "user32" Alias "FindWindowA" (Byval lpClassName As Any, Byval lpWindowName As Any) As Long

add this function to the button

Function ChooseFolder(sPrompt As String) As String
Dim lpIDList As Long
Dim sBuffer As String * 255
Dim sReturnVal As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo

sBuffer = String(Len(sBuffer),Chr(0))

szTitle = sPrompt
tBrowseInfo.hWndOwner = FindWindow95("notes",&H0)
tBrowseInfo.lpszTitle = szTitle
tBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN

lpIDList = SHBrowseForFolder(tBrowseInfo)

If (lpIDList) Then
SHGetPathFromIDList lpIDList, sBuffer
ChooseFolder = Left(sBuffer, Instr(sBuffer, Chr(0)) - 1)
End If
End Function

Put this in the click event:

a=choosefolder("Choose a directory to put the attachments into:")
Print "Putting files in: " & a

Dim uiw As New notesuiworkspace
Dim uidoc As notesuidocument
Set uidoc = uiw.currentdocument
Dim doc As notesdocument
Set doc = uidoc.document

If uidoc.isnewdoc Then
Msgbox "This utility doesn't work for new documents, save the document ( Ctrl S ), and try again."
End
End If

Set rtitem = doc.GetFirstItem( "Body" )
If ( rtitem.Type = RICHTEXT ) Then

Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
Call o.ExtractFile( a & "\" & o.Source )
Print o.source & " saved to " & a
End If
End Forall
End If

Note the Choose Directory code is originally from Daniel Alvers.