Outlook mapper

hejsa axiom
Du kan bruge dette script til at få listet antallet af ulæste emails:

Const olFolderInbox = 6

    Set objOutlook = CreateObject("Outlook.application")
    Set objNameSpace = objOutlook.GetNameSpace("MAPI")
    Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)

    For Each CurrentItem in objFolder.Items
        If CurrentItem.Unread then
            strOutput = "Sender:  " & CurrentItem.SenderName & vbCrLf
            strOutput = strOutput & "Total Attachments = " & CurrentItem.Attachments.Count & vbCrLf 
           
                        strOutput = strOutput & String(76,"~") & vbCrLf 
            strOutput = strOutput & CurrentItem.Body
        Msgbox strOutput, , CurrentItem.Subject
        End If
    Next

  If strOutput = "" Then
    Msgbox "Ingen ulæste emails", vbInformation,"Opgaver for idag"
  End If


    Set objFolder = Nothing
    Set objNameSpace = Nothing
    set objOutlook = Nothing


Håber du kan bruge det:):)

Det dur til min egen postkasse, men ikke til den postkasse som jeg har tilføjet.

Det er derfor den giver 200 point :-)

jeg tror jeg har en ide til hvad du kan gøre ...har dog scriptet liggende inde på jobbet...svarer i løbet af dagenimorgen:):)

hmmm....efetre at have undersøgt det tror jeg ikke det er muligt med .vbs scripting da du jo vil have informationer fra en anden mailbox som du kun har tilføjet som en genvej i din egen mailbox......

jeg er ret sikker på at du skal anvende Visual Basic eller lign.....for at du kan få det til at virke..

har fundet en function til at retunere mappen med. :-)

Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' folder path needs to be something like
  '  "Public Folders\All Public Folders\Company\Sales"
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function

kan du få mit script til at virke sammen med??....interessant:):)

fik du det til at virke??

Ja. vha. funktionen kan jeg finde mappen, og så anvendes jeg noget af dit script til af løbe igennem alle elementer.

hehe stort:):)

Her er lige resten, hvis der er andre der mangler noget ligende.

Sub gem()

Const olFolderInbox = 6

    Set objOutlook = CreateObject("Outlook.application")
    Set objNameSpace = objOutlook.GetNamespace("MAPI")
    Set objFolder = GetFolder("Postkasse - Ordre\Indbakke")

    For Each CurrentItem In objFolder.Items
        If CurrentItem.UnRead Then
            'find den rigtige mappe til at gemme vedhæftede filer i
            Select Case CurrentItem.SenderEmailAddress
                Case "an_adresse@danmark.dk"
                    myOrt = "c:\sti_til_hvor_jeg_vil_gemme_det\"
                Case "ordre@compotech.dk"
                    afsender = Left(CurrentItem.Subject, InStr(1, CurrentItem.Subject, "Rekv:", 1) - 2)
                    Select Case afsender
                        Case "kunde 1"
                            myOrt = "c:\sti_til_hvor_jeg_vil_gemme_det\"
                        Case Default
                            MsgBox "mail ikke gemt " & CurrentItem.Subject
                    End Select
                Case Default
                    MsgBox "mail ikke gemt " & CurrentItem.Subject
            End Select
           
            'gem filer
           
            'point on attachments
            Set myAttachments = CurrentItem.Attachments
           
            'if there are some...
            If myAttachments.Count > 0 Then
           
                'add remark to message text
'                CurrentItem.Body = CurrentItem.Body & vbCrLf & "Removed Attachments:" & vbCrLf
                   
                'for all attachments do...
                For I = 1 To myAttachments.Count
               
                    'save them to destination
                    myAttachments(I).SaveAsFile myOrt & myAttachments(I).DisplayName
   
                    'add name and destination to message text
'                    CurrentItem.Body = CurrentItem.Body & "File: " & myOrt & myAttachments(I).DisplayName & vbCrLf
                       
                Next I
            End If
        End If
    Next

    Set objFolder = Nothing
    Set objNameSpace = Nothing
    Set objOutlook = Nothing

End Sub