Πώς να εξαγάγετε τις πληροφορίες επαφών με φωτογραφίες στο Outlook;
Όταν εξάγετε επαφές από το Outlook σε ένα αρχείο, μπορείτε να εξαγάγετε μόνο τις πληροφορίες κειμένου των επαφών. Αλλά, μερικές φορές, χρειάζεστε την εξαγωγή των φωτογραφιών, καθώς και τις πληροφορίες κειμένου των επαφών, πώς θα μπορούσατε να αντιμετωπίσετε αυτήν την εργασία στο Outlook;
Εξαγωγή πληροφοριών επαφών με σχετικές φωτογραφίες χρησιμοποιώντας τον κωδικό VBA
Εξαγωγή πληροφοριών επαφών με σχετικές φωτογραφίες χρησιμοποιώντας τον κωδικό VBA
Ο παρακάτω κώδικας VBA μπορεί να σας βοηθήσει να εξαγάγετε όλες τις επαφές σε έναν συγκεκριμένο φάκελο επαφών για να διαχωρίσετε το αρχείο κειμένου με τις φωτογραφίες. Κάντε το ως εξής:
1. Επιλέξτε ένα φάκελο επαφών που θέλετε να εξαγάγετε τις επαφές με φωτογραφίες.
2. Και μετά, κρατήστε πατημένο το ALT + F11 για να ανοίξετε το Microsoft Visual Basic για εφαρμογές παράθυρο.
3. Στη συνέχεια, κάντε κλικ στο κουμπί Κύριο θέμα > Μονάδα μέτρησης, αντιγράψτε και επικολλήστε τον παρακάτω κώδικα στην ανοιχτή κενή ενότητα, δείτε το στιγμιότυπο οθόνης:
Κωδικός VBA: εξαγωγή πληροφοριών επαφών με φωτογραφίες:
Sub BatchExportContactPhotosandInformation()
Dim xContactItems As Outlook.Items
Dim xItem As Object
Dim xContactItem As ContactItem
Dim xContactInfo As String
Dim xShell As Object
Dim xFSO As Scripting.FileSystemObject
Dim xTextFile As Scripting.TextStream
Dim xAttachments As Attachments
Dim xAttachment As Attachment
Dim xSavePath, xEmailAddress As String
Dim xFolder As Outlook.Folder
On Error Resume Next
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xShell = CreateObject("Shell.application").BrowseforFolder(0, "Select a Folder", 0, 16)
If xShell Is Nothing Then Exit Sub
xSavePath = xShell.Items.Item.Path & "\"
If Outlook.Application.ActiveExplorer.CurrentFolder.DefaultItemType <> olContactItem Then
Set xFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Else
Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
End If
Set xContactItems = xFolder.Items
For i = xContactItems.Count To 1 Step -1
Set xItem = xContactItems.Item(i)
If xItem.Class = olContact Then
Set xContactItem = xItem
With xContactItem
xEmailAddress = .Email1Address
If Len(Trim(.Email2Address)) <> 0 Then
xEmailAddress = xEmailAddress & ";" & .Email2Address
End If
If Len(Trim(.Email3Address)) <> 0 Then
xEmailAddress = xEmailAddress & ";" & .Email3Address
End If
xContactInfo = "Name: " & .FullName & vbCrLf & "Email: " & _
xEmailAddress & vbCrLf & "Company: " & .CompanyName & _
vbCrLf & "Department: " & .Department & _
vbCrLf & "Job Title: " & .JobTitle & _
vbCrLf & "IM: " & .IMAddress & _
vbCrLf & "Business Phone: " & .BusinessTelephoneNumber & _
vbCrLf & "Home Phone: " & .HomeTelephoneNumber & _
vbCrLf & "BusinessFax Phone: " & .BusinessFaxNumber & _
vbCrLf & "Mobile Phone: " & .MobileTelephoneNumber & _
vbCrLf & "Business Address: " & .BusinessAddress
Set xTextFile = xFSO.CreateTextFile(xSavePath & .FullName & ".txt", True)
xTextFile.WriteLine xContactInfo
If .Attachments.Count > 0 Then
Set xAttachments = .Attachments
For Each xAttachment In xAttachments
If InStr(LCase(xAttachment.FileName), "contactpicture.jpg") > 0 Then
xAttachment.SaveAsFile (xSavePath & .FullName & ".jpg")
End If
Next
End If
End With
End If
Next i
End Sub
4. Αφού επικολλήσετε τον κώδικα στην ενότητα, κάντε κλικ Εργαλεία > αναφορές στο Microsoft Visual Basic για εφαρμογές παράθυρο, στο αναδυόμενο Αναφορές-Έργο 1 πλαίσιο διαλόγου, επιλέξτε Χρόνος εκτέλεσης δέσμης ενεργειών Microsoft Επιλογή από το Διαθέσιμες αναφορές πλαίσιο λίστας, δείτε το στιγμιότυπο οθόνης:
5. Κλίκ OK για να κλείσετε το παράθυρο διαλόγου και, στη συνέχεια, πατήστε F5 κλειδί για την εκτέλεση αυτού του κώδικα, στο αναδυόμενο Αναζήτηση φακέλου πλαίσιο διαλόγου, καθορίστε έναν φάκελο στον οποίο θέλετε να εξάγετε τις εξαγόμενες επαφές, δείτε το στιγμιότυπο οθόνης:
6. Στη συνέχεια κάντε κλικ στο κουμπί OK, όλες οι πληροφορίες με τις φωτογραφίες των επαφών έχουν εξαχθεί ξεχωριστά στον συγκεκριμένο φάκελό σας, δείτε το στιγμιότυπο οθόνης:
Τα καλύτερα εργαλεία παραγωγικότητας γραφείου
Kutools για το Outlook - Πάνω από 100 ισχυρές δυνατότητες για υπερφόρτιση του Outlook σας
🤖 Βοηθός αλληλογραφίας AI: Άμεσα επαγγελματικά email με μαγεία AI -- με ένα κλικ για ιδιοφυείς απαντήσεις, τέλειος τόνος, πολυγλωσσική γνώση. Μεταμορφώστε τα email χωρίς κόπο! ...
📧 Αυτοματοποίηση ηλεκτρονικού ταχυδρομείου: Εκτός γραφείου (Διαθέσιμο για POP και IMAP) / Προγραμματισμός αποστολής email / Αυτόματο CC/BCC βάσει κανόνων κατά την αποστολή email / Αυτόματη προώθηση (Σύνθετοι κανόνες) / Αυτόματη προσθήκη χαιρετισμού / Διαχωρίστε αυτόματα τα μηνύματα ηλεκτρονικού ταχυδρομείου πολλών παραληπτών σε μεμονωμένα μηνύματα ...
📨 Διαχείριση e-mail: Εύκολη ανάκληση email / Αποκλεισμός απάτης email από υποκείμενα και άλλους / Διαγραφή διπλότυπων μηνυμάτων ηλεκτρονικού ταχυδρομείου / Προχωρημένη Αναζήτηση / Ενοποίηση φακέλων ...
📁 Συνημμένα Pro: Μαζική αποθήκευση / Αποσύνδεση παρτίδας / Συμπίεση παρτίδας / Αυτόματη αποθήκευση / Αυτόματη απόσπαση / Αυτόματη συμπίεση ...
🌟 Διασύνδεση Magic: 😊Περισσότερα όμορφα και δροσερά emojis / Ενισχύστε την παραγωγικότητά σας στο Outlook με προβολές με καρτέλες / Ελαχιστοποιήστε το Outlook αντί να κλείσετε ...
???? Με ένα κλικ Wonders: Απάντηση σε όλους με εισερχόμενα συνημμένα / Email κατά του phishing / 🕘Εμφάνιση ζώνης ώρας αποστολέα ...
👩🏼🤝👩🏻 Επαφές & Ημερολόγιο: Μαζική προσθήκη επαφών από επιλεγμένα μηνύματα ηλεκτρονικού ταχυδρομείου / Διαχωρίστε μια ομάδα επαφής σε μεμονωμένες ομάδες / Κατάργηση υπενθυμίσεων γενεθλίων ...
Διανεμήθηκαν παραπάνω από 100 Χαρακτηριστικά Περιμένετε την εξερεύνηση σας! Κάντε κλικ εδώ για να ανακαλύψετε περισσότερα.
