E-mail opslaan in netwerk map

[Jeffie85]

Goedemorgen,

Als ik onderstaand script uitvoer ( staat in Module in VBA outlook ), dan slaat die het mailtje altijd op in 'mijn documenten', ongeacht wat ik aangeef in 'choose a folder' scherm.
Van alles al geprobeerd, maar ik kan het 'lek' even niet vinden.

Wie kan en wil mij helpen.
bvd.

Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
  Dim StrFolderPath  As String
  
    StrFolderPath = BrowseForFolder("\\dataserver\Data\")
    enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
   
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
     
    'sPath = enviro & "\Documents\"
    'StrFolderPath = BrowseForFolder(sPath)
    
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG
  
  End If
  Next

  
End Sub

 
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

 

[Jeffie85]

Deze hoort er ook nog onder...

Function BrowseForFolder(Optional OpenAt As String) As String
     
    Dim ShellApp As Object
     
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then
            BrowseForFolder = ""
        End If
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then
            BrowseForFolder = ""
        End If
    Case Else
        BrowseForFolder = ""
    End Select
     
ExitFunction:
     
    Set ShellApp = Nothing
     
End Function

 

[edmoor]

Je gebruikt de variabele sPath als folder om de mail in op te slaan.
Maar deze krijgt nergens een waarde.

 

[Jeffie85]

sPath heb ik uitgezet toch?

Maar hoe krijg ik dit weg, zodat die gewoon op slaat in de map die je aangeeft?

 

[edmoor]

Uiteraard moet je daar dan de variabele gebruiken waarin de waarde van BrowseForFolder wordt geplaatst.

 

[Jeffie85]

Kun je opzet geven?

 

[edmoor]

Niet getest, wel van overbodige zaken ontdaan:

Public Sub SaveMessageAsMsg()
     Dim oMail As Outlook.MailItem
     Dim StrFolderPath  As String
     Dim objItem As Object
     Dim sName As String
     Dim dtDate As Date
     
    [COLOR="#FF0000"] StrFolderPath[/COLOR] = BrowseForFolder("\\dataserver\Data\")
     For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
           Set oMail = objItem
           sName = oMail.Subject
           ReplaceCharsForFileName sName, "-"
           
           dtDate = oMail.ReceivedTime
           sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                   vbUseSystem) & Format(dtDate, "-hhnnss", _
                   vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
           oMail.SaveAs[COLOR="#FF0000"] StrFolderPath & "\" & [/COLOR]sName, olMSG
        End If
     Next
End Sub

 

[Jeffie85]

Helemaal super !
het werkt.

Stel, ik wil bij het scherm 'choose a folder' gelijk starten in de map; 'C:\Program Files (x86)\Microsoft Office'
Nu begint die natuurlijk altijd bij de basis van de mappen structuur en moet je elke keer verder klikken tot....C:\Program Files (x86)\Microsoft Office ( voorbeeld )

scheelt een hoop klikken zeg maar....

 

[edmoor]

Gebruik die van mij.
Aanroep: sPath = BrowseForFolder ("C:\Program Files (x86)\Microsoft Office")

Dan wel dit:
oMail.SaveAs StrFolderPath & "\" & sName, olMSG

Weer wijzigen in dit:
oMail.SaveAs sPath & sName, olMSG

Function BrowseForFolder(strStartingFolder As Variant) As String
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Selecter een folder:", 0, strStartingFolder)
    If Not TypeName(objFolder) = "Nothing" Then
        Set objFolderItem = objFolder.self
        BrowseForFolder = objFolderItem.Path & "\"
    Else
        BrowseForFolder = ""
    End If

    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function

 

[Jeffie85]

objShell en objFolder

is geen variabele gedefinieerd....

( Dim aanroeping denk ik ? )

 

[edmoor]

Inderdaad.
Dan heb je kennelijk Option Explicit aan staan. Doe dan direct onder deze regel:
Function BrowseForFolder(strStartingFolder As Variant) As String

Het volgende:
Dim objFolderItem As Object
Dim objFolder As Object
Dim objShell As Object

 

[Jeffie85]

objFolderItem heb ik er ook bij gezet

hij werkt super.... !!

ben er heel blij mee
super bedankt !!

 

[edmoor]

Graag gedaan

 

[snb]

Hoe bedenken ze het toch .....


Verwijder Option Explicit.
En gebruik niet meer variabelen dan nodig

Sub M_snb()
  c00=CreateObject("Shell.Application").BrowseForFolder(0, "Selecteer een folder:", 0, "\\server\start\") & "\"

  For Each it In ActiveExplorer.Selection
    If it.MessageClass = "IPM.Note" Then it.SaveAs c00 & format(it.receivedtime,"yyyymmdd_hhmmss_") & it.subject & ".msg", olMSG
  Next
End Sub