MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 04.02.2019, 16:42   #1
enca_andi
Neuer Benutzer
Neuer Benutzer
Standard VBA - Excel Datei aus Outlook automatisiert wegspeichern

Hallo liebes Forum,

ich würde gerne im Outlook täglich eine Mail, welche eine Excel Datei tickets.xls enthält als tickets.xlsx (wichtig ist das andere Format hier) in den Ordner: Desktop automatisiert wegspeichern

und zwar immer wenn die Mail von folgender Adresse kommt Support@firma.com und folgenden Betreff hat: Automated Report

Kann mir hier bitte hier jemand behilflich sein. Ich kenne mich leider nicht mit VBA richtig aus, habe aber diesen Code hier unten gefunden..... vielleicht ist dieser hilfreich.

Beste Grüße
Andi







'---------------------------------------------------------------------------------
' 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
enca_andi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 14:57   #2
enca_andi
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Kann mir hier bitte jemand weiterhelfen? Ganz lieben Dank schon mal
enca_andi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 15:04   #3
ebs17
MOF Guru
MOF Guru
Standard

Diese Geschichte erscheint mir arg umfangreich.

Outlook-VBA kennt ein Ereignis NewMail. Da wärst Du schon an der richtigen Stelle, um zu prüfen, ob es diese neue Mail die gewünschte Mail mit Absender, Betreff, Anlage usw. ist, und wenn man sie einmal in den Händen hält, kann man auch das Speichern der Anlage direkt veranlassen.

Auch in Outlook kommt man per Alt+F11 in den VBA-Editor und mit F2 in den Objektkatalog.

__________________

Ein freundliches Glück Auf!

Eberhard

Abfrageperformance ist kein Geheimnis
SQL ist leicht: {0}:{1}:{2}:{3}:{4}:{5}:{6}:{7}:{8}:{9}:{10}:{11}
Dein Dankeschön: DBWiki=>Spende
ebs17 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 15:06   #4
enca_andi
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo Eberhard

dh. ich brauche einen VBA Code dafür oder geht das als Filter Regelung mittlerweile schon?

Dh. ich könnte dann auch sagen, bitte speichere mir die Datei nicht als xls sondern als xlsx?

Ganz lieben Dank
Andi
enca_andi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 15:06   #5
enca_andi
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

ich kann nämlich leider 0 VBA programmieren, heul......
enca_andi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 15:10   #6
MisterBurns
MOF Meister
MOF Meister
Standard

Hallo Andi,

wieso du für ein Outlookproblem in einem Excelforum fragst, ist mir schleierhaft. Wenn dich die Schuhe drücken, gehst du doch auch erstmal in ein Schuhgeschäft und nicht zum Orthopäden, oder?

Schau mal hier
https://webdata.de/index.php/kontakt...isch-speichern
Da kannst du den Code für dich anpassen und dann eine Outlookregel erstellen (ist auch dort beschrieben). Wenn du damit nicht weiterkommst, wende dich an ein Outlookforum, die Leute dort werden dir vermutlich schneller helfen als die Excelanten hier.

__________________

Schöne Grüße
Berni
MisterBurns ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 15:17   #7
ebs17
MOF Guru
MOF Guru
Standard

Zitat:

ich kann nämlich leider 0 VBA programmieren

So eine Formulierung klingt in meinen Ohren jedes Mal so, als sollte dieser Zustand verewigt werden.
Dann empfehle ich den Schritt in die Job-Börse. Wer nicht kann und nicht will, kann anstellen.

__________________

Ein freundliches Glück Auf!

Eberhard

Abfrageperformance ist kein Geheimnis
SQL ist leicht: {0}:{1}:{2}:{3}:{4}:{5}:{6}:{7}:{8}:{9}:{10}:{11}
Dein Dankeschön: DBWiki=>Spende
ebs17 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.02.2019, 07:53   #8
enca_andi
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

danke für die Rückmeldung.

es geht ja hier um einen VBA Code deswegen dachte ich mir dass ich in dem Forum richtig bin. Hier sind nämlich echt super nette und tolle experten

danke schon mal für die Hilfe

den Outlook vba code habe ich beim googeln auch gefunden nur wie kann ich dem code sagen save as xlsx (die Datei als xlsx Format speichern)
enca_andi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.02.2019, 07:54   #9
enca_andi
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Sub SaveToDisk(olMail As MailItem)

Dim Pfad As String
Dim Datei As Attachments
Pfad = "C:Archiv" 'Der Pfad muss entsprechend angepasst werden. Wichtig ist der letzte Backslash

On Error Resume Next

Set Datei = olMail.Attachments
For i = 1 To Datei.Count
Datei.Item(i).SaveAsFile Pfad & Datei.Item(i).FileName
Next i

End Sub
enca_andi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.02.2019, 08:33   #10
MisterBurns
MOF Meister
MOF Meister
Standard

Ich hab mir das jetzt grad nochmal angeschaut, mit diesem Code funktioniert das automatische Speichern wunderbar:
https://blog.soprani.at/2015/09/11/o...dnungmusssein/

Allerdings musst du dich wohl von dem Gedanken verabschieden, dass du einfach so die Datei als .xlsx abspeichern kannst. Das kann Outlook nämlich nicht. Und einfach nur ein "x" anhängen funktioniert zwar, dann kann Excel die Datei aber nicht mehr lesen und meldet sie als beschädigt.

Erläutere doch mal, wieso du überhaupt eine .xlsx brauchst.

__________________

Schöne Grüße
Berni
MisterBurns ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.02.2019, 10:35   #11
hubert17
MOF User
MOF User
Standard

Hallo Andi,

füge mal folgenden Code in Outlook in ThisOutlookSession ein:
Code:

Option Explicit

Private Sub Application_NewMail()
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim i As Integer
Dim strSaveFolder As String
Dim strEmail As String
Dim strSubject As String

' Excel Variablen
Dim xlApp As Object
Dim xlDatei
Dim strFile As String

strEmail = "Support@firma.com"      ' Hier die E-Mailadresse des Absenders eintragen
strSubject = "Automated Report"     ' Hier den erforderlichen Betreff eintragen
strSaveFolder = "C:Users\[Benutzername]\Desktop\"   ' Hier den Pfad zum Desktop oder Speicherort eintragen

    On Error Resume Next
    Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    
    For Each objNewMail In objPosteingang.Items
        
        With objNewMail
            If .UnRead = True And .SenderEmailAddress = strEmail And .Subject = strSubject Then
                If .Attachments.Count > 0 Then
                    For i = 1 To .Attachments.Count
                        .Attachments.Item(i).SaveAsFile strSaveFolder & .Attachments.Item(i).FileName
                        Set xlApp = CreateObject("Excel.Application")
        
                        With xlApp
                            .Visible = False                    ' Excel wird nicht auf dem Bildschirm geöffnet, ansonsten "True" setzen
                            .EnableEvents = True
                        End With
                        
                        strFile = strSaveFolder & .Attachments.Item(i).FileName
                        
                        Set xlDatei = xlApp.Workbooks.Open(strFile)
                        xlDatei.SaveAs FileName:=strSaveFolder & "tickets.xlsx"
                        xlApp.Quit
                        
                        Kill strFile   ' löscht die xls-Datei auf dem Desktop

                    Next i
                Else
                    MsgBox "Es ist eine neue E-Mail vom Absender: " & strEmail & " und dem Betreff: " & _
                        strSubject & " eingegangen, aber es ist keine Datei als Anhang vorhanden!"
                End If
            End If
        End With
    Next objNewMail
End Sub
Beim ankommen einer neuen E-Mail wird überprüft ob die E-Mail ungelesen ist, den entsprechenden Absender hat und auch der Betreff übereinstimmt.
Der Anhang, Datei wird erstmal auf dem Desktop gespeichert, Danach wird die Datei dann in Excel geöffnet und als tickets.xlsx auf dem Desktop gespeichert. Voraussetzung ist hier natürlich, das eine entsprechende Excel-Version vorhanden ist.

__________________

Gruß
Hubert

Geändert von hubert17 (14.02.2019 um 12:09 Uhr).
hubert17 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 21:12 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.