Note: The other languages of the website are Google-translated. Back to English

Πώς να εξαγάγετε μηνύματα ηλεκτρονικού ταχυδρομείου από πολλούς φακέλους / υποφακέλους για να υπερέχετε στο Outlook;

Κατά την εξαγωγή ενός φακέλου με τον Οδηγό εισαγωγής και εξαγωγής στο Outlook, δεν υποστηρίζει το Συμπερίληψη υποφακέλων επιλογή εάν εξάγετε το φάκελο σε αρχείο CSV. Ωστόσο, θα είναι πολύ χρονοβόρα και κουραστική η εξαγωγή κάθε φακέλου σε αρχείο CSV και, στη συνέχεια, η μετατροπή του σε βιβλίο εργασίας Excel με μη αυτόματο τρόπο. Εδώ, αυτό το άρθρο θα εισαγάγει ένα VBA για γρήγορη εξαγωγή πολλαπλών φακέλων και υποφακέλων σε βιβλία εργασίας του Excel με ευκολία.

Εξαγωγή πολλών μηνυμάτων ηλεκτρονικού ταχυδρομείου από πολλούς φακέλους / υποφακέλους στο Excel με VBA

Καρτέλα Office - Ενεργοποίηση επεξεργασίας καρτέλας και περιήγησης στο Office και να κάνετε την εργασία πολύ πιο εύκολη ...
Kutools για Outlook - Φέρνει 100 ισχυρές προηγμένες δυνατότητες στο Microsoft Outlook
  • Αυτόματο CC / BCC με κανόνες κατά την αποστολή email · Αυτόματη προώθηση Πολλαπλά email μέσω κανόνων. Αυτόματη απάντηση χωρίς διακομιστή ανταλλαγής και περισσότερες αυτόματες δυνατότητες ...
  • Προειδοποίηση BCC - εμφάνιση μηνύματος όταν προσπαθείτε να απαντήσετε όλα εάν η διεύθυνση αλληλογραφίας σας βρίσκεται στη λίστα BCC. Υπενθύμιση όταν λείπουν συνημμένακαι περισσότερες λειτουργίες υπενθύμισης ...
  • Απάντηση (Όλα) με όλα τα συνημμένα στη συνομιλία μέσω ταχυδρομείου. Απάντηση σε πολλά email ταυτόχρονα. Αυτόματη προσθήκη χαιρετισμού κατά την απάντηση Αυτόματη προσθήκη ημερομηνίας και ώρας στο θέμα ...
  • Εργαλεία συνημμένου: Αυτόματη αποσύνδεση, Συμπίεση όλων, Μετονομασία όλων, Αυτόματη αποθήκευση όλων ... Γρήγορη αναφορά, Καταμέτρηση επιλεγμένων μηνυμάτων, Κατάργηση διπλών μηνυμάτων και επαφών ...
  • Περισσότερες από 100 προηγμένες δυνατότητες θα λύστε τα περισσότερα από τα προβλήματά σας στο Outlook 2021 - 2010 ή στο Office 365. Πλήρεις δυνατότητες δωρεάν δοκιμή 60 ημερών.

βέλος μπλε δεξιά φούσκα Εξαγωγή πολλών μηνυμάτων ηλεκτρονικού ταχυδρομείου από πολλούς φακέλους / υποφακέλους στο Excel με VBA

Ακολουθήστε τα παρακάτω βήματα για να εξαγάγετε μηνύματα ηλεκτρονικού ταχυδρομείου από πολλούς φακέλους ή υποφακέλους σε βιβλία εργασίας του Excel με VBA στο Outlook.

1. Τύπος άλλος + F11 για να ανοίξετε το παράθυρο της Microsoft Visual Basic for Applications.

2. κλικ Κύριο θέμα > Μονάδα μέτρησηςκαι, στη συνέχεια, επικολλήστε κάτω από τον κώδικα VBA στο νέο παράθυρο Module.

VBA: Εξαγωγή μηνυμάτων ηλεκτρονικού ταχυδρομείου από πολλούς φακέλους και υποφακέλους στο Excel

Const MACRO_NAME = "Export Outlook Folders to Excel"

Sub ExportMain()
ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"
ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"
MsgBox "Process complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub
Sub ExportToExcel(strFilename As String, strFolderPath As String)
Dim      olkMsg As Object
Dim olkFld As Object
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Integer
Dim intVersion As Integer

If strFilename <> "" Then
If strFolderPath <> "" Then
Set olkFld = OpenOutlookFolder(strFolderPath)
If TypeName(olkFld) <> "Nothing" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
End With
intRow = 2
For Each olkMsg In olkFld.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
Else
MsgBox "The folder '" & strFolderPath & "' does not exist in Outlook.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The folder path was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If
Else
MsgBox "The filename was empty.", vbCritical + vbOKOnly, MACRO_NAME
End If

Set olkMsg = Nothing
Set olkFld = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub

Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant
Dim varFolder As Variant
Dim bolBeyondRoot As Boolean

On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function

Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry
Dim olkEnt As Object

On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTPEX(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function

Function SMTPEX(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.propertyAccessor
On Error Resume Next
Set olkPA = olkMsg.propertyAccessor
SMTPEX = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function

3. Παρακαλώ προσαρμόστε τον παραπάνω κωδικό VBA όπως χρειάζεστε.

(1) Αντικαταστήστε προορισμός_φάκελος_διαδρομή στον παραπάνω κώδικα με τη διαδρομή του φακέλου του φακέλου προορισμού, θα αποθηκεύσετε τα εξαγόμενα βιβλία εργασίας, όπως C: \ Users \ DT168 \ Documents \ TEST.
(2) Αντικαταστήστε το_email_accouny \ folder \ subfolder_1 και το_email_accouny \ folder \ subfolder_2 στον παραπάνω κώδικα με τις διαδρομές φακέλων των υποφακέλων στο Outlook, όπως Κέλι @extendoffice.com \ Εισερχόμενα \ Α και Κέλι @extendoffice.com \ Εισερχόμενα \ Β

4. Πάτα το F5 ή κάντε κλικ στο τρέξιμο για να εκτελέσετε αυτό το VBA. Και μετά κάντε κλικ στο OK κουμπί στο αναδυόμενο παράθυρο διαλόγου Εξαγωγή φακέλων Outlook στο Excel. Δείτε το στιγμιότυπο οθόνης:

Και τώρα τα email από όλους τους καθορισμένους υποφακέλους ή φακέλους στον παραπάνω κώδικα VBA εξάγονται και αποθηκεύονται σε βιβλία εργασίας του Excel.


βέλος μπλε δεξιά φούσκαΣχετικά άρθρα


Kutools για Outlook - Φέρνει 100 προηγμένες δυνατότητες στο Outlook και κάνει την εργασία πολύ πιο εύκολη!

  • Αυτόματο CC / BCC με κανόνες κατά την αποστολή email · Αυτόματη προώθηση Πολλαπλά μηνύματα ηλεκτρονικού ταχυδρομείου κατά παραγγελία. Αυτόματη απάντηση χωρίς διακομιστή ανταλλαγής και περισσότερες αυτόματες δυνατότητες ...
  • Προειδοποίηση BCC - εμφάνιση μηνύματος όταν προσπαθείτε να απαντήσετε σε όλα εάν η διεύθυνση αλληλογραφίας σας βρίσκεται στη λίστα BCC; Υπενθύμιση όταν λείπουν συνημμένακαι περισσότερες λειτουργίες υπενθύμισης ...
  • Απάντηση (Όλα) Με όλα τα συνημμένα στη συνομιλία μέσω ταχυδρομείου; Απάντηση σε πολλά email σε δευτερόλεπτα; Αυτόματη προσθήκη χαιρετισμού κατά την απάντηση Προσθήκη ημερομηνίας στο θέμα ...
  • Εργαλεία συνημμένων: Διαχείριση όλων των συνημμένων σε όλα τα μηνύματα, Αυτόματη απόσπαση, Συμπίεση όλων, Μετονομασία όλων, Αποθήκευση όλων ... Γρήγορη αναφορά, Καταμέτρηση επιλεγμένων μηνυμάτων...
  • Ισχυρά ανεπιθύμητα email κατά παραγγελία? Κατάργηση διπλότυπων μηνυμάτων και επαφών... Σας επιτρέπουν να κάνετε πιο έξυπνα, πιο γρήγορα και καλύτερα στο Outlook.
shot kutools outlook kutools καρτέλα 1180x121
shot kutools outlook kutools συν καρτέλα 1180x121
 
Σχόλια (10)
Δεν υπάρχουν ακόμη βαθμολογίες. Γίνε ο πρώτος που θα αξιολογήσετε!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Πώς μπορώ να το επαναφέρω αυτόματα σε υποφακέλους;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
γεια σου αγαπητέ, όλα λειτουργούν καλά, ευχαριστώ, αλλά το σώμα δεν εξάγεται, πώς μπορώ να εξαγάγω και το σώμα του email, το αρχείο excel μόλις έχει (Θέμα, Λήψη και Αποστολέα), αν μπορείς να με ενημερώσεις με αυτό θα λύσει ένα τεράστιο θέμα στην επιχείρησή μου ευχαριστώ και πάλι
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Montaser,
Η δέσμη ενεργειών VBA εκτελείται με βάση τη δυνατότητα Εξαγωγής του Outlook, η οποία δεν υποστηρίζει την εξαγωγή περιεχομένου μηνυμάτων κατά τη μαζική εξαγωγή μηνυμάτων ηλεκτρονικού ταχυδρομείου από έναν φάκελο αλληλογραφίας. Επομένως, αυτό το σενάριο VBA δεν μπορεί επίσης να εξάγει περιεχόμενο μηνύματος.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό λειτουργεί άψογα, αλλά υπάρχει τρόπος να προσθέσετε τις πληροφορίες όχι μόνο για τα 4 παραπάνω πεδία αλλά και για όλα αυτά που δίνει η εξαγωγή του Outlook σε PST; Σώμα θέματος Από: (Όνομα) Από: (Διεύθυνση) Από: (Τύπος) Προς: (Όνομα) Προς: (Διεύθυνση) Προς: (Τύπος) CC: (Όνομα) CC: (Διεύθυνση) CC: (Τύπος) BCC: ( Όνομα) BCC: (Διεύθυνση) BCC: (Τύπος) Πληροφορίες χρέωσης Κατηγορίες Σημασία Ευαισθησία χιλιομέτρων

Προσπάθησα να προσθέσω "Σημασία" και λειτουργεί, αλλά θα εκτιμούσα αν κάποιος μπορούσε να δώσει τον κωδικό για τα άλλα πεδία. σας ευχαριστώ!!
Με excWks
.Cells(1, 1) = "Θέμα"
.Cells(1, 2) = "Ελήφθηκε"
.Cells(1, 3) = "Αποστολέας"
.Cells(1, 4) = "Σώμα"
.Cells(1, 5) = "Σημασία"
Τέλος με
introw = 2
Για κάθε olkMsg Σε olkFld.Items
«Μόνο μηνύματα εξαγωγής, όχι αποδείξεις ή αιτήματα ραντεβού κ.λπ.
Αν olkMsg.Class = olMail Τότε
«Προσθέστε μια σειρά για κάθε πεδίο στο μήνυμα που θέλετε να εξαγάγετε
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
excWks.Cells(intRow, 4) = olkMsg.Body
excWks.Cells(intRow, 5) = olkMsg.Importance
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, ελέγξτε τον παρακάτω κωδικό σύμφωνα με τις ανάγκες σας:
Const MACRO_NAME = "Εξαγωγή φακέλων του Outlook στο Excel"

Sub ExportMain()

ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"

ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"

MsgBox "Η διαδικασία ολοκληρώθηκε.", vbInformation + vbOKOnly, MACRO_NAME

Sub End

Sub ExportToExcel(strΌνομα αρχείου ως συμβολοσειρά, strFolderPath ως συμβολοσειρά)

Dim olkMsg ως αντικείμενο

Dim olkFld ως αντικείμενο

Dim excApp ως αντικείμενο

Dim excWkb ως αντικείμενο

Dim excWks ως αντικείμενο

Dim intRow ως ακέραιος αριθμός

Dim intVersion ως ακέραιος

Εάν strΌνομα αρχείου <> "" Τότε

Αν strFolderPath <> "" Τότε

Ορισμός olkFld = OpenOutlookFolder(strFolderPath)

Αν TypeName(olkFld) <> "Τίποτα" Τότε

intVersion = GetOutlookVersion()

Ορισμός excApp = CreateObject ("Excel.Application")

Ορισμός excWkb = excApp.Workbooks.Add()

Ορισμός excWks = excWkb.ActiveSheet

«Γράψτε τις κεφαλίδες στηλών του Excel

Με excWks

.Cells(1, 1) = "Θέμα"

.Cells(1, 2) = "Σώμα"

.Cells(1, 3) = "Ελήφθηκε"

.Cells(1, 4) = "Από: (Όνομα)"

.Cells(1, 5) = "Από: (Διεύθυνση)"

.Cells(1, 6) = "Από: (Τύπος)"

.Cells(1, 7) = "Προς: (Όνομα)"

.Cells(1, 8) = "Προς: (Διεύθυνση)"

.Cells(1, 9) = "Προς: (Τύπος)"

.Cells(1, 10) = "CC: (Όνομα)"

.Cells(1, 11) = "CC: (Διεύθυνση)"

.Cells(1, 12) = "CC: (Τύπος)"

.Cells(1, 13) = "BCC: (Όνομα)"

.Cells(1, 14) = "BCC: (Διεύθυνση)"

.Cells(1, 15) = "BCC: (Τύπος)"

.Cells(1, 16) = "Στοιχεία χρέωσης"

.Cells(1, 17) = "Categories"

.Cells(1, 18) = "Σημασία"

.Cells(1, 19) = "Χιλιόμετρα"

.Cells(1, 20) = "Sensitivity"

Τέλος με

introw = 2

Για κάθε olkMsg Σε olkFld.Items

«Μόνο μηνύματα εξαγωγής, όχι αποδείξεις ή αιτήματα ραντεβού κ.λπ.

Αν olkMsg.Class = olMail Τότε

«Προσθέστε μια σειρά για κάθε πεδίο στο μήνυμα που θέλετε να εξαγάγετε

excWks.Cells(intRow, 1) = olkMsg.Subject

excWks.Cells(intRow, 2) = olkMsg.Body

excWks.Cells(intRow, 3) = olkMsg.ReceivedTime

excWks.Cells(intRow, 4) = olkMsg.SenderName

excWks.Cells(intRow, 5) = GetAddress(olkMsg.Sender, intVersion)

excWks.Cells(intRow, 6) = olkMsg.Sender.Type

excWks.Cells(intRow, 7) = GetRecipientsName(olkMsg, 1, 1, intVersion)

excWks.Cells(intRow, 8) = GetRecipientsName(olkMsg, 1, 2, intVersion)

excWks.Cells(intRow, 9) = GetRecipientsName(olkMsg, 1, 3, intVersion)

excWks.Cells(intRow, 10) = GetRecipientsName(olkMsg, 2, 1, intVersion)

excWks.Cells(intRow, 11) = GetRecipientsName(olkMsg, 2, 2, intVersion)

excWks.Cells(intRow, 12) = GetRecipientsName(olkMsg, 2, 3, intVersion)

excWks.Cells(intRow, 13) = GetRecipientsName(olkMsg, 3, 1, intVersion)

excWks.Cells(intRow, 14) = GetRecipientsName(olkMsg, 3, 2, intVersion)

excWks.Cells(intRow, 15) = GetRecipientsName(olkMsg, 3, 3, intVersion)

excWks.Cells(intRow, 16) = olkMsg.BillingInformation

excWks.Cells(intRow, 17) = olkMsg.Categories

excWks.Cells(intRow, 18) = olkMsg.Importance

excWks.Cells(intRow, 19) = olkMsg.Mileage

excWks.Cells(intRow, 20) = olkMsg.Sensitivity

intRow = intRow + 1

End If

Επόμενο

Ορισμός olkMsg = Τίποτα

excWkb.SaveAs strΌνομα αρχείου

excWkb.Κλείσιμο

Αλλού

MsgBox "Ο φάκελος "" & strFolderPath & "" δεν υπάρχει στο Outlook.", vbCritical + vbOKOnly, MACRO_NAME

End If

Αλλού

MsgBox "Η διαδρομή του φακέλου ήταν κενή.", vbCritical + vbOKOnly, MACRO_NAME

End If

Αλλού

MsgBox "Το όνομα αρχείου ήταν κενό.", vbCritical + vbOKOnly, MACRO_NAME

End If



Ορισμός olkMsg = Τίποτα

Ορισμός olkFld = Τίποτα

Ορισμός excWks = Τίποτα

Ορισμός excWkb = Τίποτα

Ορισμός excApp = Τίποτα

Sub End



Δημόσια συνάρτηση OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder

Dim arrFolders As Variant

Dim varFolder As Variant

Dim bolBeyondRoot As Boolean

On Error Συνέχιση Επόμενη

Αν strFolderPath = "" Τότε

Ορισμός OpenOutlookFolder = Τίποτα

Αλλού

Do while Left(strFolderPath, 1) = "\"

strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)

Βρόχος

arrFolders = Split(strFolderPath, "\")

Για κάθε varFolder Στο arrFolders

Επιλέξτε Case bolBeyondRoot

Υπόθεση Λάθος

Ορισμός OpenOutlookFolder = Outlook.Session.Folders(varFolder)

bolBeyondRoot = Αληθινό

Υπόθεση Αλήθεια

Ορισμός OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)

Επιλέξτε Τερματισμός

Αν Σφάλμα.Αριθμός <> 0 Τότε

Ορισμός OpenOutlookFolder = Τίποτα

Έξοδος για

End If

Επόμενο

End If

Στο σφάλμα GoTo 0

Τέλος Λειτουργία



Η συνάρτηση GetOutlookVersion() ως ακέραιος αριθμός

Dim arrVer As Variant

arrVer = Split(Outlook.Version, ".")

GetOutlookVersion = arrVer(0)

Τέλος Λειτουργία



Συνάρτηση SMTPEX(Εισαγωγή ως Εισαγωγή Διεύθυνσης) Ως συμβολοσειρά

Dim olkPA ως Outlook.PropertyAccessor

On Error Συνέχιση Επόμενη

Ορισμός olkPA = Entry.PropertyAccessor

SMTPEX = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")

Στο σφάλμα GoTo 0

Ορισμός olkPA = Τίποτα

Τέλος Λειτουργία



Συνάρτηση GetAddress (Entry As AddressEntry, intOutlookVersion ως Integer) Ως συμβολοσειρά

Dim olkEnt As Object

On Error Συνέχιση Επόμενη

Επιλέξτε Case intOutlookVersion

Η περίπτωση είναι < 14

If Entry.Type = "EX" Τότε

GetAddress = SMTPEX (Είσοδος)

Αλλού

GetAddress = Είσοδος.Διεύθυνση

End If

Υπόθεση άλλο

Εάν Entry.AddressEntryUserType = olExchangeUserAddressEntry Τότε

Ορίστε olkEnt = Entry.GetExchangeUser

GetAddress = olkEnt.PrimarySmtpAddress

Αλλού

GetAddress = Είσοδος.Διεύθυνση

End If

Επιλέξτε Τερματισμός

Στο σφάλμα GoTo 0

Ορισμός olkEnt = Τίποτα

Τέλος Λειτουργία



Συνάρτηση GetRecipientsName(Item As MailItem, rcpType As Integer, Ret as Integer, intOutlookVersion as Integer) Ως συμβολοσειρά

Dim xRcp ως παραλήπτης

Dim xNames As String

xNames = ""

Για κάθε xRcp In Item.Recipients

Αν xRcp.Type = rcpType Τότε

Αν Ret = 1 Τότε

Αν xNames = "" Τότε

xNames = xRcp.Name

Αλλού

xNames = xNames & "; " & xRcp.Name

End If

ElseIf Ret = 2 Τότε

Αν xNames = "" Τότε

xNames = GetAddress (xRcp.AddressEntry, intOutlookVersion)

Αλλού

xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

End If

ElseIf Ret = 3 Τότε

Αν xNames = "" Τότε

xNames = xRcp.AddressEntry.Type

Αλλού

xNames = xNames & "; " & xRcp.AddressEntry.Type

End If

End If

ElseIf xRcp.Type = rcpType Τότε

Αν Ret = 1 Τότε

Αν xNames = "" Τότε

xNames = xRcp.Name

Αλλού

xNames = xNames & "; " & xRcp.Name

End If

ElseIf Ret = 2 Τότε

Αν xNames = "" Τότε

xNames = GetAddress (xRcp.AddressEntry, intOutlookVersion)

Αλλού

xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

End If

ElseIf Ret = 3 Τότε

Αν xNames = "" Τότε

xNames = xRcp.AddressEntry.Type

Αλλού

xNames = xNames & "; " & xRcp.AddressEntry.Type

End If

End If

ElseIf xRcp.Type = rcpType Τότε

Αν Ret = 1 Τότε

Αν xNames = "" Τότε

xNames = xRcp.Name

Αλλού

xNames = xNames & "; " & xRcp.Name

End If

ElseIf Ret = 2 Τότε

Αν xNames = "" Τότε

xNames = GetAddress (xRcp.AddressEntry, intOutlookVersion)

Αλλού

xNames = xNames & "; " & GetAddress(xRcp.AddressEntry, intOutlookVersion)

End If

ElseIf Ret = 3 Τότε

Αν xNames = "" Τότε

xNames = xRcp.AddressEntry.Type

Αλλού

xNames = xNames & "; " & xRcp.AddressEntry.Type

End If

End If

End If

Επόμενο

GetRecipientsName = xNames

Τέλος Λειτουργία




Ελπίζω αυτό να λειτουργεί για εσάς.
Amanda
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Στο δευτερεύον ExporttoExcel μπορείτε να προσθέσετε το σώμα

«Γράψτε τις κεφαλίδες στηλών του Excel
Με excWks
.Cells(1, 1) = "Θέμα"
.Cells(1, 2) = "Ελήφθηκε"
.Cells(1, 3) = "Αποστολέας"
.Cells(1, 4) = "Σώμα"
Τέλος με
introw = 2
Για κάθε olkMsg Σε olkFld.Items
«Μόνο μηνύματα εξαγωγής, όχι αποδείξεις ή αιτήματα ραντεβού κ.λπ.
Αν olkMsg.Class = olMail Τότε
«Προσθέστε μια σειρά για κάθε πεδίο στο μήνυμα που θέλετε να εξαγάγετε
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
excWks.Cells(intRow, 4) = olkMsg.Body
intRow = intRow + 1
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, ελπίζω ότι κάποιος μπορεί να με βοηθήσει εδώ, ουσιαστικά δεν έχω γνώση της VB, αλλά έχω καταφέρει να κάνω αυτό το σενάριο να λειτουργεί για μένα μέχρι στιγμής.

Ωστόσο, έχω συνολικά περίπου 1500 φακέλους και υποφακέλους κάτω από τα εισερχόμενά μου και θα ήθελα πραγματικά μια απλή δέσμη ενεργειών για την εξαγωγή όλης της διεύθυνσης email στην οποία έχω στείλει με τη γραμμή θέματος και την ημερομηνία σε ξεχωριστές στήλες στο Excel.

Έχω ψάξει για μέρες και δοκίμασα πολλούς διαφορετικούς ιστότοπους, αλλά δεν μπορώ να βρω κανέναν κωδικό για να λειτουργήσει εκτός από αυτόν.


Είναι εφικτό αυτό που ζητάω; Αν ναι, υπάρχει κάποιος εκεί έξω ευγενικός και αρκετά έξυπνος για να με βοηθήσει να φτιάξω το σενάριο που χρειάζομαι;
Υποθέτω ότι έχει να κάνει με αυτό το μέρος:


Sub ExportMain()

ExportToExcel "destination_folder_path\A.xlsx", "your_email_accouny\folder\subfolder_1"

ExportToExcel "destination_folder_path\B.xlsx", "your_email_accouny\folder\subfolder_2"

MsgBox "Η διαδικασία ολοκληρώθηκε.", vbInformation + vbOKOnly, MACRO_NAME

Sub End


Χάρη στην προηγμένη
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας,
Μόλις έτρεξα αυτό το Macro που λειτουργεί καλά.
Το καταλαβαίνω στις εκφράσεις
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)

το olkMsg.* και το GetSMTPAddress(olkMsg, intVersion) εξάγουν περιεχόμενο από το Outlook.

Ποιο είναι το όρισμα που πρέπει να χρησιμοποιήσετε για να λάβετε τη Διεύθυνση στην οποία στάλθηκε το μήνυμα;

Όταν χρησιμοποιείτε τον Οδηγό εξαγωγής του Outlook, είναι δυνατή η εξαγωγή αυτής της διεύθυνσης, επομένως υποθέτω ότι θα ήταν δυνατό να γίνει μέσω αυτής της μακροεντολής (με κάποια τροποποίηση).
Μπορεί κάποιος να βοηθήσει;

Χαιρετισμούς
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Εκτελώ αυτήν τη μακροεντολή, αλλά συνεχίζω να λαμβάνω σφάλμα μεταγλώττισης:

User=defined type δεν ορίζεται

Στη γραμμή 62 " Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder "

Έχω ήδη καθορίσει τη διαδρομή ως εξής:

ExportToExcel "C:\Users\kudus\Documents\MailExportTest\f1\A.xlsx", "myname@mydomain.com\Inbox\Black Hat Webcast"
ExportToExcel "C:\Users\\Documekudus\Documents\MailExportTest\f2\B.xlsx", "myname@mydomain.com\Inbox\CPD\Kaplan Training"

Χρησιμοποιώ το Outlook 2016 σε περίπτωση που χρειαστεί
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Το έφτιαξα. Από το παράθυρο του Visual Basic, μεταβείτε στο Tools Reference - και στο πλαίσιο για "Microsoft Outlook 16.0 Object Library"

Δεν υπάρχουν σχόλια δημοσιεύτηκε ακόμα
Αφήστε τα σχόλιά σας
Δημοσίευση ως επισκέπτης
×
Αξιολογήστε αυτήν την ανάρτηση:
0   Χαρακτήρες
Προτεινόμενες τοποθεσίες

Ακολουθησε μας

Πνευματικά δικαιώματα © 2009 - www.extendoffice.com. | Ολα τα δικαιώματα διατηρούνται. Τροφοδοτείται από ExtendOffice. | Sitemap
Το Microsoft και το λογότυπο του Office είναι εμπορικά σήματα ή σήματα κατατεθέντα της Microsoft Corporation στις Ηνωμένες Πολιτείες ή / και σε άλλες χώρες.
Προστατεύεται από το Sectigo SSL