Helpmij.nl
Helpmij.nl
Helpmij.nl
Steun Helpmij.nl! Klik hier     Computerprobleem? Klik hier!

Quote

Pagina 1 van 3 1 2 3 LaatsteLaatste
Weergeven resultaten 1 tot 20 van 41

Onderwerp: Script voor opslaan bijlagen

  1. #1
    Vraag is opgelost

    Script voor opslaan bijlagen

    Goedemiddag,

    Ik heb via google een vba script gevonden die bijlagen vanuit Outlook opslaat naar een bepaalde map.
    Werkt echt als een speer !
    Alleen zou ik graag willen dat hij alleen de bijlagen die .pdf bestanden bevatten opslaat.
    Hoe kan ik dit aanpassen ?

    Alvast hartelijk dank !

    Gr,
    Marten


    '---------------------------------------------------------------------------------
    ' The sample scripts are not supported under any Microsoft standard support
    ' program or service. The sample scripts are provided AS IS without warranty
    ' of any kind. Microsoft further disclaims all implied warranties including,
    ' without limitation, any implied warranties of merchantability or of fitness for
    ' a particular purpose. The entire risk arising out of the use or performance of
    ' the sample scripts and documentation remains with you. In no event shall
    ' Microsoft, its authors, or anyone else involved in the creation, production, or
    ' delivery of the scripts be liable for any damages whatsoever (including,
    ' without limitation, damages for loss of business profits, business interruption,
    ' loss of business information, or other pecuniary loss) arising out of the use
    ' of or inability to use the sample scripts or documentation, even if Microsoft
    ' has been advised of the possibility of such damages.
    '---------------------------------------------------------------------------------

    Option Explicit

    ' *****************
    ' For Outlook 2010.
    ' *****************
    #If VBA7 Then
    ' The window handle of Outlook.
    Private lHwnd As LongPtr

    ' /* API declarations. */
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As LongPtr

    ' *****************************************
    ' For the previous version of Outlook 2010.
    ' *****************************************
    #Else
    ' The window handle of Outlook.
    Private lHwnd As Long

    ' /* API declarations. */
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
    #End If

    ' The class name of Outlook window.
    Private Const olAppCLSN As String = "rctrl_renwnd32"
    ' Windows desktop - the virtual folder that is the root of the namespace.
    Private Const CSIDL_DESKTOP = &H0
    ' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
    Private Const BIF_RETURNONLYFSDIRS = &H1
    ' Do not include network folders below the domain level in the dialog box's tree view control.
    Private Const BIF_DONTGOBELOWDOMAIN = &H2
    ' The maximum length for a path is 260 characters.
    Private Const MAX_PATH = 260

    ' ######################################################
    ' Returns the number of attachements in the selection.
    ' ######################################################
    Public Function SaveAttachmentsFromSelection() As Long
    Dim objFSO As Object ' Computer's file system object.
    Dim objShell As Object ' Windows Shell application object.
    Dim objFolder As Object ' The selected folder object from Browse for Folder dialog box.
    Dim objItem As Object ' A specific member of a Collection object either by position or by key.
    Dim selItems As Selection ' A collection of Outlook item objects in a folder.
    Dim atmt As Attachment ' A document or link to a document contained in an Outlook item.
    Dim strAtmtPath As String ' The full saving path of the attachment.
    Dim strAtmtFullName As String ' The full name of an attachment.
    Dim strAtmtName(1) As String ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
    Dim strAtmtNameTemp As String ' To save a temporary attachment file name.
    Dim intDotPosition As Integer ' The dot position in an attachment name.
    Dim atmts As Attachments ' A set of Attachment objects that represent the attachments in an Outlook item.
    Dim lCountEachItem As Long ' The number of attachments in each Outlook item.
    Dim lCountAllItems As Long ' The number of attachments in all Outlook items.
    Dim strFolderPath As String ' The selected folder path.
    Dim blnIsEnd As Boolean ' End all code execution.
    Dim blnIsSave As Boolean ' Consider if it is need to save.

    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0

    On Error Resume Next

    Set selItems = ActiveExplorer.Selection

    If Err.Number = 0 Then

    ' Get the handle of Outlook window.
    lHwnd = FindWindow(olAppCLSN, vbNullString)

    If lHwnd <> 0 Then

    ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
    Set objShell = CreateObject("Shell.Application")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
    BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

    ' /* Failed to create the Shell application. */
    If Err.Number <> 0 Then
    MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
    Err.Description & ".", vbCritical, "Error from Attachment Saver"
    blnIsEnd = True
    GoTo PROC_EXIT
    End If

    If objFolder Is Nothing Then
    strFolderPath = ""
    blnIsEnd = True
    GoTo PROC_EXIT
    Else
    strFolderPath = CGPath(objFolder.Self.Path)

    ' /* Go through each item in the selection. */
    For Each objItem In selItems
    lCountEachItem = objItem.Attachments.Count

    ' /* If the current item contains attachments. */
    If lCountEachItem > 0 Then
    Set atmts = objItem.Attachments

    ' /* Go through each attachment in the current item. */
    For Each atmt In atmts

    ' Get the full name of the current attachment.
    strAtmtFullName = atmt.FileName

    ' Find the dot postion in atmtFullName.
    intDotPosition = InStrRev(strAtmtFullName, ".")

    ' Get the name.
    strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
    ' Get the file extension.
    strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
    ' Get the full saving path of the current attachment.
    strAtmtPath = strFolderPath & atmt.FileName

    ' /* If the length of the saving path is not larger than 260 characters.*/
    If Len(strAtmtPath) <= MAX_PATH Then
    ' True: This attachment can be saved.
    blnIsSave = True

    ' /* Loop until getting the file name which does not exist in the folder. */
    Do While objFSO.FileExists(strAtmtPath)
    strAtmtNameTemp = strAtmtName(0) & _
    Format(Now, "_mmddhhmmss") & _
    Format(Timer * 1000 Mod 1000, "000")
    strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)

    ' /* If the length of the saving path is over 260 characters.*/
    If Len(strAtmtPath) > MAX_PATH Then
    lCountEachItem = lCountEachItem - 1
    ' False: This attachment cannot be saved.
    blnIsSave = False
    Exit Do
    End If
    Loop

    ' /* Save the current attachment if it is a valid file name. */
    If blnIsSave Then atmt.SaveAsFile strAtmtPath
    Else
    lCountEachItem = lCountEachItem - 1
    End If
    Next
    End If

    ' Count the number of attachments in all Outlook items.
    lCountAllItems = lCountAllItems + lCountEachItem
    Next
    End If
    Else
    MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
    blnIsEnd = True
    GoTo PROC_EXIT
    End If

    ' /* For run-time error:
    ' The Explorer has been closed and cannot be used for further operations.
    ' Review your code and restart Outlook. */
    Else
    MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
    blnIsEnd = True
    End If

    PROC_EXIT:
    SaveAttachmentsFromSelection = lCountAllItems

    ' /* Release memory. */
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
    If Not (objItem Is Nothing) Then Set objItem = Nothing
    If Not (selItems Is Nothing) Then Set selItems = Nothing
    If Not (atmt Is Nothing) Then Set atmt = Nothing
    If Not (atmts Is Nothing) Then Set atmts = Nothing

    ' /* End all code execution if the value of blnIsEnd is True. */
    If blnIsEnd Then End
    End Function

    ' #####################
    ' Convert general path.
    ' #####################
    Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <> "" Then Path = Path & ""
    CGPath = Path
    End Function

    ' ######################################
    ' Run this macro for saving attachments.
    ' ######################################
    Public Sub ExecuteSaving()
    Dim lNum As Long

    lNum = SaveAttachmentsFromSelection

    If lNum > 0 Then
    MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
    Else
    MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
    End If
    End Sub

  2. #2

  3. #3
    Giga Honourable Senior Member
    Verenigingslid

    Geregistreerd
    12 juni 2008
    Wat een verschrikkelijke code voor zoiets simpels.

    Kopieer en gebruik geen code die je niet begrijpt.

    En zet vooral VBA-code tussen Code tags voor de leesbaarheid.
    VBA voor smarties
    VBA is een taal die je moet leren met een grammatica- en een woordenboek.

    http://www.helpmij.nl/forum/showthread.php/635117-Tips-om-de-helpers-in-deze-sectie-van-dienst-te-zijn
    Plaats svp geen bestanden op andere sites; nadat het bestand daar verwijderd is wordt een forumdraad onbegrijpelijk voor anderen.

  4. #4
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 september 2000
    Locatie
    Zuid-Holland
    Onder dit stukje:
    Code:
    ' Get the full name of the current attachment.
    Kan je zo kijken of de bijlage een PDF extensie heeft:
    Code:
    If LCase(Right(atmt.FileName, 3)) = "pdf" Then
    
    End If
    Daarnaast, wat snb zegt.
    Laatst aangepast door edmoor : 14 november 2017 om 12:20
    "Hardware: The parts of a computer system that can be kicked. "
    Op rechtstreekse vragen via email reageer ik niet. Daar is het forum voor.

  5. #5
    Hartelijk dank voor jullie reacties.
    Ik heb het stukje vervangen door:

    ' Get the full name of the current attachment.
    If LCase(Right(atmt.FileName, 3)) = "pdf" Then
    strAtmtFullName = atmt.FileName
    End If

    Maar behalve de pdf bestanden worden ook de img bestanden opgeslagen. (bijvoorbeeld bij een handtekening waar een plaatje in zit)
    Sorry voor deze slordige code maar heb zelf niet de kennis om dit voor elkaar te krijgen.
    Vandaar dat ik alleen gebruik kan maken van bestaande code.
    Het mooie hiervan is dat je een hele blok van bijvoorbeeld 60 mailtjes kunt maken en alle bijlagen dan vervolgens in 1 map kunt opslaan.
    Ideaal aangezien wij op het werk vaak 60 lossen mailtjes binnenkrijgen met allemaal verschillende facturen die we normaal gesproken stuk voor stuk handmatig moeten opslaan.
    Met deze code kan dat in 1 keer !
    Mocht de naam van de bijlage al bestaan dan krijgt deze een andere naam. Het moet vast en zeker een stuk korter kunnen maar zou niet weten hoe...

  6. #6
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 september 2000
    Locatie
    Zuid-Holland
    Ik gaf je alleen de controle, daar moet je uiteraard wel verder mee gaan.
    "Hardware: The parts of a computer system that can be kicked. "
    Op rechtstreekse vragen via email reageer ik niet. Daar is het forum voor.

  7. #7
    Ik ben echt nog een beginner op dit gebied.
    Zou erg mooi zijn als je me een stukje op weg zou kunnen helpen.
    Scheelt voor ons bedrijf echt ontzettend veel tijd als we dit voor elkaar kunnen krijgen.

  8. #8
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 september 2000
    Locatie
    Zuid-Holland
    Kijk eens naar deze. Wel even bij de groene regel het pad aanpassen:
    Code:
    Private WithEvents Items As Outlook.Items
    
    Private Sub Application_Startup()
        Dim olApp As Outlook.Application
        Dim objNS As Outlook.NameSpace
        Set olApp = Outlook.Application
        Set objNS = olApp.GetNamespace("MAPI")
        Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
    End Sub
    
    Private Sub Items_ItemAdd(ByVal item As Object)
        On Error GoTo ErrorHandler
        If TypeName(item) = "MailItem" Then
            Call saveAttachtoDisk(Item)
        End If
      
    ProgramExit:
        Exit Sub
    
    ErrorHandler:
        MsgBox Err.Number & " - " & Err.Description
        Resume ProgramExit
    End Sub
    
    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
          Dim objAtt As Outlook.Attachment
          Dim saveFolder As String: saveFolder = "C:\PDF Bestanden\" 'Deze aanpassen!
          Dim dateFormat: dateFormat = Format(Now, "dd-mm-yyyy")
          Dim strFile As String
        
          For Each objAtt In itm.Attachments
             If Right(objAtt.FileName, 3) = "pdf" Then
                 objAtt.SaveAsFile saveFolder & dateFormat & objAtt.FileName
             End If
          Next objAtt
        
          Set objAtt = Nothing
    End Sub
    E.e.a. wordt uitgevoerd als er een mail binnen komt.
    Laatst aangepast door edmoor : 14 november 2017 om 13:58
    "Hardware: The parts of a computer system that can be kicked. "
    Op rechtstreekse vragen via email reageer ik niet. Daar is het forum voor.

  9. #9
    Hartelijk dank !
    Alleen we willen graag zelf een aantal mailtjes kunnen selecteren en dan handmatig de macro starten.
    Het is namelijk niet de bedoeling dat alle mailtjes die binnenkomen met een pdf als bijlage hierin opgeslagen worden.
    Daarom was die vorige code ook zo makkelijk....

  10. #10
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 september 2000
    Locatie
    Zuid-Holland
    Sorry, maar die code is een dusdanig drama dat ik die niet ga lezen om aan te passen en ik nu helaas geen tijd om mijn voorbeeld er op aan te passen.
    "Hardware: The parts of a computer system that can be kicked. "
    Op rechtstreekse vragen via email reageer ik niet. Daar is het forum voor.

  11. #11
    Dat begrijp ik....Is jouw code dan wel zo aan te passen dat je via een selectie van mailtjes dit ook voor elkaar kunt krijgen ?
    Anders hebben we gewoon pech gehad.

  12. #12
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 september 2000
    Locatie
    Zuid-Holland
    Uiteraard kan dat. Ik wil er vanavond wel even naar kijken.
    Nog even geduld dus, tenzij iemand anders hier me voor is.
    "Hardware: The parts of a computer system that can be kicked. "
    Op rechtstreekse vragen via email reageer ik niet. Daar is het forum voor.

  13. #13
    Zou echt geweldig zijn.
    De facturen die we krijgen hebben vaak dezelfde bestandsnaam, op het moment van opslaan moet de pdf dus wel een unieke naam krijgen om ervoor te zorgen dat de bestanden niet overschreven worden.
    Alvast super bedankt ! :-)

  14. #14
    Giga Honourable Senior Member
    Verenigingslid

    Geregistreerd
    12 juni 2008
    Ik weet tegen betaling (zelf word je natuurlijk ook maandelijks betaald) wel iemand die dat voor jouw bedrijf kan programmeren.
    VBA voor smarties
    VBA is een taal die je moet leren met een grammatica- en een woordenboek.

    http://www.helpmij.nl/forum/showthread.php/635117-Tips-om-de-helpers-in-deze-sectie-van-dienst-te-zijn
    Plaats svp geen bestanden op andere sites; nadat het bestand daar verwijderd is wordt een forumdraad onbegrijpelijk voor anderen.

  15. #15
    Ja, dat begrijp ik.
    Maar soms kun je mensen ook helpen zonder ervoor betaald te krijgen.
    Vriendendienst zeg maar... :-)

  16. #16
    Giga Honourable Senior Member
    Verenigingslid

    Geregistreerd
    12 juni 2008
    Ik wacht....
    VBA voor smarties
    VBA is een taal die je moet leren met een grammatica- en een woordenboek.

    http://www.helpmij.nl/forum/showthread.php/635117-Tips-om-de-helpers-in-deze-sectie-van-dienst-te-zijn
    Plaats svp geen bestanden op andere sites; nadat het bestand daar verwijderd is wordt een forumdraad onbegrijpelijk voor anderen.

  17. #17
    Tera Honourable Senior Member
    Verenigingslid
    OctaFish's avatar
    Geregistreerd
    6 februari 2009
    Locatie
    Rotterdam
    Afstand tot server
    ±151 km
    Probeer deze macro eens.
    Code:
    Sub GetAttachments()
    '************************** OOOO **************************
    '*** Code by Martin Green ******** martin@fontstuff.com ***
    '******* Office Tips Web Site - www.fontstuff.com *********
    '**********************************************************
    
    ' This Outlook macro checks a the Outlook Inbox for messages with attached files (of any type) and saves them to disk.
    ' NOTE: make sure the specified save folder exists before running the macro.
        On Error GoTo GetAttachments_err
    
    ' Declare variables
        Dim NS As NameSpace
        Dim Inbox As MAPIFolder
        Dim item As Object
        Dim atmt As Attachment
        Dim FileName As String
        Dim i As Integer
        Set NS = GetNamespace("MAPI")
        Set Inbox = NS.GetDefaultFolder(olFolderInbox)
        i = 0
    
    ' Check Inbox for messages and exit of none found
        If Inbox.Items.Count = 0 Then
            MsgBox "There are no messages in the Inbox.", vbInformation, "Nothing Found"
            Exit Sub
        End If
    
    ' Check each message for attachments
        For Each item In Inbox.Items
    
    ' Save any attachments found
            For Each atmt In item.Attachments
            ' This path must exist! Change folder name as necessary.
                FileName = "H:\MailArchief\Bijlagen\" & atmt.FileName
                atmt.SaveAsFile FileName
                i = i + 1
             Next atmt
        Next item
    
    ' Show summary message
        If i > 0 Then
            MsgBox "I found " & i & " attached files." _
            & vbCrLf & "I have saved them into the C:\Email Attachments folder." _
            & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
        Else
            MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
        End If
    
    ' Clear memory
    GetAttachments_exit:
        Set atmt = Nothing
        Set item = Nothing
        Set NS = Nothing
        Exit Sub
    
    ' Handle errors
    GetAttachments_err:
        MsgBox "An unexpected error has occurred." _
            & vbCrLf & "Please note and report the following information." _
            & vbCrLf & "Macro Name: GetAttachments" _
            & vbCrLf & "Error Number: " & Err.Number _
            & vbCrLf & "Error Description: " & Err.Description _
            , vbCritical, "Error!"
        Resume GetAttachments_exit
    End Sub
    Gebruik de QUOTE knop alleen als je iets wit citeren.
    Op deze pagina kun je zien hoe je met TAGS werkt.

  18. #18
    Goedeavond Octafish,
    Hartelijk dank !
    Hij geeft de melding "there a no new messages in the inbox"
    Maar als ik het script zo bekijk zet hij alles naar 1 bepaalde directory en kun je ook geen selectie maken van bepaalde mailtjes.

    Het mooiste zou zijn als ik een selectie kan maken van mailberichten met bijlagen en dan vervolgende een macro kan starten die mij vervolgens de keuze geeft waar ik de bijlagen kan opslaan. Dit geeft meer flexibiliteit, ook richting mijn collega's. De bedoeling is dan om alleen de pdf bestanden op te slaan onder een unieke naam. Het 1e script (wat sommige gebruikers een "bagger" script vinden) doet dat keurig alleen slaat hij alles op, ook de img bestanden zoals bijvoorbeeld de handtekening onder de mail.

  19. #19
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 september 2000
    Locatie
    Zuid-Holland
    Probeer deze maar eens. Selecteer een aantal berichten en voer deze dan uit:
    Code:
    Public Sub SaveSelectionAttachments()
        Dim currentExplorer As Explorer
        Dim obj As Object
    
        Set currentExplorer = Application.ActiveExplorer
        Set Selection = currentExplorer.Selection
    
        For Each obj In Selection
           With obj
               If .Attachments.Count > 0 Then
                   If Right(.Attachments(1).FileName, 3) = "pdf" Then
                        .Attachments(1).SaveAsFile "C:\PDF Bestanden\" & Format(Now, "yyyymmddhhmmss_") & .Attachments(1).FileName
                   End If
               End If
           End With
        Next
    
        Set currentExplorer = Nothing
        Set Selection = Nothing
        Set obj = Nothing
    End Sub
    Je zal er andere dingen bij willen, maar deze moet het als basis in ieder geval doen.
    Laatst aangepast door edmoor : 14 november 2017 om 20:57
    "Hardware: The parts of a computer system that can be kicked. "
    Op rechtstreekse vragen via email reageer ik niet. Daar is het forum voor.

  20. #20
    Onder Outlook 2010 werkt deze inderdaad perfect.
    Alleen onder Outlook 2016 schijft hij de bestanden niet weg.

Pagina 1 van 3 1 2 3 LaatsteLaatste

Berichtenregels

  • U mag geen nieuwe vragen starten.
  • U mag niet reageren op berichten.
  • U mag geen bijlagen versturen.
  • U mag uw berichten niet bewerken.
  •  
Helpmij.nl
Helpmij.nl

Helpmij.nl en business

Partners
Sponsoren
Aanbiedingen