Скопируйте гиперссылку с сайта электронной почты Outlook и экспортируйте в excel или notepad

Вот что я ищу:

У меня есть 20 разных папок в Outlook, у каждого есть та же структура и формат электронной почты. у каждого органа электронной почты есть от 3 до 7 гиперссылок. Я хочу экспортировать одну из этих гиперссылок (ее легко определить, поскольку она имеет один и тот же начальный / конкретный текст внутри – неважно, экспортируем ли мы эту гиперссылку или все из них, потому что мы могут впоследствии редактировать их в excel).

Я хочу, чтобы эти гиперссылки были экспортированы в ячейки на листе excel

ЧТО Я ПРАВАЮТ СЕЙЧАС:

Я использую буфер обмена, чтобы перейти к каждому письму. щелкните правой кнопкой мыши ссылку на копию, а затем вставьте в блокнот или превью.

дайте мне знать, если у вас есть какие-то предложения. Это действительно упростит мою работу … и, конечно же, любого другого, кто может искать похожие решения.

С уважением,

А.А.

Вы можете экспортировать в excel, но перед копированием в Excel,

-> Вы должны выбрать электронные письма, в которых присутствуют гиперссылки. Выбрав электронную почту righclick и выберите « Отправить» в одну заметку .

-> Откроется одна заметка. Переверните вкладки страниц в этом разделе (с правой стороны) одной заметки. выберите все письма (страницы) и щелкните правой кнопкой мыши -> скопировать .

  1. Теперь вы можете вставить скопированные элементы в блокнот .
  2. Теперь вы можете копировать все содержимое в блокноте, чтобы преуспеть.
  3. вы можете найти или применить фильтр, filter-> textfilter-> содержит требуемое слово или фразу (его легко идентифицировать, поскольку он имеет один и тот же запуск / определенное слово внутри) .

  4. Если u непосредственно копирует из onenote в excel означает, что все таблицы, вложения и другие будут вставлены, тогда будет сложно отфильтровать или найти требуемые гиперссылки.

  5. так как вы говорите, что в 20 папках невозможно отправить папки в onenote , вам нужно открыть папку 20, тогда вы можете выбрать любое количество писем в каждой папке.

🙂

Я не могу подойти к моему решению в одном ответе, потому что он превышает ограничение по размеру. Это часть 2 моего ответа. Он содержит блок кода, описанный в части 1. Сначала прочитайте часть 1 .

Option Explicit Public Type MAPIFolderDtl NameParent As String Folder As MAPIFolder NumMail As Long NumMeet As Long End Type ' ----------------------------------------------------------------------- ' ## Insert other routines here ' ----------------------------------------------------------------------- Sub FindInterestingFolders(ByRef IntFolderList() As MAPIFolderDtl, _ WantMail As Boolean, WantMeet As Boolean, _ NameSep As String, _ ParamArray NameFullList() As Variant) ' * Return a list of interesting folders. ' * To be interesting a folder must be named or be a subfolder of a named ' folder and contain mail and or meeting items if wanted. ' * Note: a top level folder cannot be returned as interesting because such ' folders are not of type MAPIFolder. ' * IntFolders() The list of interesting folders. See Type MAPIFolderDtl for ' contents. ' * WantMail True if a folder containing mail items is to be classified ' as interesting. ' * WantMeet True if a folder containing meeting items is to be classified ' as interesting. ' * NameSep SubFolder Names in NameList are of the form: ' "Personal Folders" & NameSep & "Inbox" ' NameSep can be any character not used in a folder name. It ' appears any character could be used in a folder name including ' punctuation characters. If in doubt, try Tab. ' * NameFullList One or more full names of folders which might themselves be ' interesting or might be the parent an interesting folders. Dim InxTLFList() As Long Dim InxIFLCrnt As Long Dim InxNFLCrnt As Long Dim InxTLFCrnt As Variant Dim NameFullCrnt As String Dim NamePartFirst As String Dim NamePartRest As String Dim Pos As Long Dim TopLvlFolderList As Folders InxIFLCrnt = 0 ' Nothing in IntFolderList() Set TopLvlFolderList = CreateObject("Outlook.Application").GetNamespace("MAPI").Folders For InxNFLCrnt = LBound(NameFullList) To UBound(NameFullList) NameFullCrnt = NameFullList(InxNFLCrnt) ' Get next name ' Split name into first part and the rest. For Example, ' "Personal Folders|NHSIC|Commisioning" will be split into: ' NamePartFirst: Personal Folders ' NamePartRest: NHSIC|Commissioning Pos = InStr(1, NameFullCrnt, NameSep) If Pos = 0 Then NamePartFirst = NameFullCrnt NamePartRest = "" Else NamePartFirst = Mid(NameFullCrnt, 1, Pos - 1) NamePartRest = Mid(NameFullCrnt, Pos + 1) End If ' Create list of indices into TopLvlFolderList in ' ascending sequence by folder name Call SimpleSortFolders(TopLvlFolderList, InxTLFList) ' NamePartFirst should be the name of a top level ' folder or empty. Ignore if it is not. For Each InxTLFCrnt In InxTLFList If NamePartFirst = "" Or _ TopLvlFolderList.Item(InxTLFCrnt).Name = NamePartFirst Then ' All subfolders are a different type so they ' are handled by FindInterestingSubFolder Call FindInterestingSubFolders(IntFolderList, InxIFLCrnt, _ "", TopLvlFolderList.Item(InxTLFCrnt), WantMail, _ WantMeet, NameSep, NamePartRest) End If Next Next If InxIFLCrnt = 0 Then ' No folders found ReDim IntFolderList(0 To 0) Else ReDim Preserve IntFolderList(1 To InxIFLCrnt) ' Discard unused entries 'For InxIFLCrnt = 1 To UBound(IntFolderList) ' Debug.Print IntFolderList(InxIFLCrnt).NameParent & "|" & _ ' IntFolderList(InxIFLCrnt).Folder.Name & " " & _ ' IntFolderList(InxIFLCrnt).NumMail & " " & _ ' IntFolderList(InxIFLCrnt).NumMeet 'Next End If End Sub Sub FindInterestingSubFolders(ByRef IntFolderList() As MAPIFolderDtl, _ InxIFLCrnt As Long, NameParent As String, _ MAPIFolderCrnt As MAPIFolder, WantMail As Boolean, _ WantMeet As Boolean, NameSep As String, _ NameChild As String) ' * NameFull = "" ' MAPIFolderCrnt and all its subfolders are potentially of interest ' * NameFull <> "" ' Look further down hierarchy for subfolders of potential interest ' This routine can be called repeately by a parent routine to explore different parts ' of the folder hierarchy. It calls itself recursively to work down the hierarchy. ' IntFolderList ' Array of interesting folders. ' InxIFLCrnt ' On the first call, InxIFLCrnt will be zero and the state of ' IntFolderList will be undefined. ' NameParent ' ... Grandparent & NameSep & Parent ' MAPIFolderCrnt ' The current folder that is to be explored. ' WantMail ' True if a folder has to contain mail to be interesting ' WantMeet ' True if a folder has to contain meeting items to be interesting ' NameSep ' The name separator character ' NameChild ' Suppose the original path was xxx|yyy|zzz. For each recurse down ' a name is removed from the start of NameChild and added to the end ' of NameParent. When NameChild is blank, the target folder has ' been reached. Dim InxSFList() As Long Dim InxSFCrnt As Variant Dim NameCrnt As String Dim NamePartFirst As String Dim NamePartRest As String Dim NumMail As Long Dim NumMeet As Long Dim Pos As Long Pos = InStr(1, NameChild, NameSep) If Pos = 0 Then NamePartFirst = NameChild NamePartRest = "" Else NamePartFirst = Mid(NameChild, 1, Pos - 1) NamePartRest = Mid(NameChild, Pos + 1) End If If NameParent = "" Then ' This folder has no parent. It cannot be interesting. NameCrnt = MAPIFolderCrnt.Name Else ' This folder has a parent. It could be interesting. NameCrnt = NameParent & NameSep & MAPIFolderCrnt.Name If NamePartFirst = "" Then If FolderHasRequiredItems(MAPIFolderCrnt, WantMail, _ WantMeet, NumMail, NumMeet) Then ' Debug.Print NameCrnt & " interesting" If InxIFLCrnt = 0 Then ReDim IntFolderList(1 To 100) End If InxIFLCrnt = InxIFLCrnt + 1 If InxIFLCrnt > UBound(IntFolderList) Then ReDim Preserve IntFolderList(1 To 100 + UBound(IntFolderList)) End If IntFolderList(InxIFLCrnt).NameParent = NameParent Set IntFolderList(InxIFLCrnt).Folder = MAPIFolderCrnt IntFolderList(InxIFLCrnt).NumMail = NumMail IntFolderList(InxIFLCrnt).NumMeet = NumMeet Else ' Debug.Print NameCrnt & " not interesting" End If End If End If If MAPIFolderCrnt.Folders.Count = 0 Then ' No subfolders Else Call SimpleSortMAPIFolders(MAPIFolderCrnt, InxSFList) For Each InxSFCrnt In InxSFList If NamePartFirst = "" Or _ MAPIFolderCrnt.Folders(InxSFCrnt).Name = NamePartFirst Then Select Case NamePartFirst ' Ignore folders that can cause problems Case "Sync Issues" Case "RSS Feeds" Case "Public Folders" Case Else ' Recurse to analyse next level down Call FindInterestingSubFolders(IntFolderList, InxIFLCrnt, NameCrnt, _ MAPIFolderCrnt.Folders(InxSFCrnt), WantMail, _ WantMeet, NameSep, NamePartRest) End Select End If Next End If End Sub Function FolderHasRequiredItems(MAPIFolderCrnt As MAPIFolder, WantMail As Boolean, _ WantMeet As Boolean, ByRef NumMail As Long, _ ByRef NumMeet As Long) As Boolean ' Return True if folder is interested. That is: at least one of the following is true: ' WantMail = True And NumMail > 0 ' WantMeet = True And NumMeet > 0 ' Values for NumMail and NumMeet are set whether or not the folder is interesting Dim FolderItem As Object Dim FolderItemClass As Long Dim InxItemCrnt As Long NumMail = 0 NumMeet = 0 ' Count mail and meeting items in folder For InxItemCrnt = 1 To MAPIFolderCrnt.Items.Count Set FolderItem = MAPIFolderCrnt.Items.Item(InxItemCrnt) ' This seems to avoid syncronisation errors FolderItemClass = 0 On Error Resume Next FolderItemClass = FolderItem.Class On Error GoTo 0 Select Case FolderItemClass Case olMail NumMail = NumMail + 1 Case olMeetingResponsePositive, olMeetingRequest, olMeetingCancellation, _ olMeetingResponseNegative, olMeetingResponseTentative NumMeet = NumMeet + 1 End Select Next If WantMail And NumMail > 0 Then FolderHasRequiredItems = True Exit Function End If If WantMeet And NumMeet > 0 Then FolderHasRequiredItems = True Exit Function End If FolderHasRequiredItems = False End Function Sub SimpleSortMAPIFolders(MAPIFolderList As MAPIFolder, _ ByRef InxArray() As Long) ' On exit InxArray contains the indices into MAPIFolderList sequenced by ' ascending name. The sort is performed by repeated passes of the list ' of indices that swap adjacent entries if the higher come first. ' Not an efficient sort but adequate for short lists. Dim InxIACrnt As Long Dim InxIALast As Long Dim NoSwap As Boolean Dim TempInt As Long Debug.Assert MAPIFolderList.Folders.Count >= 1 ' Must be at least one folder ReDim InxArray(1 To MAPIFolderList.Folders.Count) ' One entry per folder ' Fill array with indices For InxIACrnt = 1 To UBound(InxArray) InxArray(InxIACrnt) = InxIACrnt Next ' Each repeat of the loop movest the folder with the highest name ' to the end of the list. Each repeat checks one less entry. ' Each repeats partially sorts the leading entries and may result ' in the list being sorted before all loops have been performed. For InxIALast = UBound(InxArray) To 1 Step -1 NoSwap = True For InxIACrnt = 1 To InxIALast - 1 If MAPIFolderList.Folders(InxArray(InxIACrnt)).Name > _ MAPIFolderList.Folders(InxArray(InxIACrnt + 1)).Name Then NoSwap = False ' Move higher entry one slot towards the end TempInt = InxArray(InxIACrnt) InxArray(InxIACrnt) = InxArray(InxIACrnt + 1) InxArray(InxIACrnt + 1) = TempInt End If Next If NoSwap Then Exit For End If Next End Sub 

Я не могу подойти к моему решению в одном ответе, потому что он превышает ограничение по размеру. Это часть 1 моего ответа. Я переместил один блок кода во второй ответ.

Это решение VBA. Вы даете хорошие спецификации, поэтому я считаю, что это будет близко к вашему требованию. Надеюсь, я включил достаточно комментариев, чтобы вы могли вносить окончательные корректировки. Если нет, спросите.

Этот первый блок кода содержит подпрограммы, написанные мной для меня. Они выполняют задачи, которые я нахожу полезными. Они включают комментарии, но они являются комментариями, написанными, чтобы напомнить мне, что они не помогают кому-то понять их. Макросы, которые я написал для вас, используют их, и я объясню, как их использовать. На данный момент я предлагаю вам не беспокоиться о том, как эти подпрограммы выполняют то, что они делают.

Я должен предупредить вас, что я редко использую функции обработки ошибок в своих собственных макросах, потому что я не хочу, чтобы они терпели неудачу изящно; Я хочу, чтобы они остановились на описании проблемы, чтобы я мог понять и исправить причину.

В Outlook, откройте редактор VBA, вставьте модуль и скопируйте в него этот первый блок кода. Вам также необходимо нажать « Tools затем « References . Является ли «Microsoft Excel nn.n Object Library» ближе к вершине и отмечена ли она? Если он не отмечен, вы должны прокрутить список, найти эту ссылку и пометить ее. Значение «nn.n» будет зависеть от версии Excel, которую вы используете. Только если у вас установлена ​​более одной версии Excel, у вас будет выбор.

Ответ продолжался ниже кода.

Этот код переместился во вторую часть ответа.

Ниже приведены четыре макроса. Первые три являются учебниками, а четвертое – моим решением.

Если ваша установка Outlook похожа на мою, у вас будут папки « Личные папки» , « Архивные папки» и, возможно, другие. В личных папках у вас будут стандартные папки « Входящие» , « Исходящие» и т. Д. Возможно, вы добавили свои собственные папки в эти стандартные папки или, возможно, добавили их в личные папки . В моей собственной системе у меня есть множество папок, в том числе : Семья и Тони . Каждый из них содержит подпапки и одну из подпапок внутри ! Тони – это Амазонка .

В первом макросе, которое вам больше всего нужно понять:

  Call FindInterestingFolders(FolderList, True, False, "|", _ "Personal Folders|!Family", "Personal Folders|!Tony|Amazon") 

FindInterestingFolders – одна из подпрограмм, включенных в код выше. Вторая строка этого оператора указывает, в удобном для меня стиле, имена двух упомянутых мной папок. Макрос FindInterestingFolders возвращает информацию об этих двух папках и любых подпапках или под-папках, которые они могут иметь. Вам придется заменить эти два имени на нужные вам папки. Если 20 папок находятся под одним родителем, вы можете указать одного родителя. Если 20 папок разбросаны, вам может потребоваться указать имена всех 20.

Первый макрос выводит в Immediate Window имена всех папок, найденных FindInterestingFolders . В моей системе он выводит:

 Personal Folders|!Family|Chloe & Euan Personal Folders|!Family|Geoff Personal Folders|!Family|Lucy & Mark Personal Folders|!Tony|Amazon Personal Folders|!Tony|Amazon|Trueshopping Ltd 

Скопируйте этот макрос в созданный выше модуль и поиграйте с ним, пока не получите его, чтобы создать список из 20 папок, которые вы хотите найти.

Ответ продолжался ниже кода.

 Sub ExtractHyperLinks1() ' Outputs a sorted list of interesting folders to the Immediate Window. Dim FolderList() As MAPIFolderDtl Dim InxFL As Long ' Set FolderList to a list of interesting folders. ' The True means a folder has to containing mail items to be interesting. ' The False means I am uninterested in meeting items. ' The "|" defines the name separator used in the list of folder names ' that follow. Call FindInterestingFolders(FolderList, True, False, "|", _ "Personal Folders|!Family", "Personal Folders|!Tony|Amazon") For InxFL = LBound(FolderList) To UBound(FolderList) With FolderList(InxFL) Debug.Print .NameParent & "|" & .Folder.Name End With Next End Sub 

Надеюсь, это было не слишком сложно. Вам придется скопировать измененный вызов FindInterestingFolders в следующие макросы.

Macro 2 основывается на макросе 1. Он ищет интересные папки для почтовых отправлений с помощью тел Html. Для каждого тела Html он ищет метки привязки и выходы в окне Immediate Window каждый тег и следующие 58 символов. В окне Immediate Window отображаются только последние 200 или около того, поэтому вы можете видеть только нижнюю часть вывода. Это не имеет значения; идея состоит в том, чтобы дать вам первый взгляд на то, что может видеть макрос. В моей системе выход заканчивается:

  Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from Amazon customer ... <A HREF="mailto:[email protected]">ma <A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht <A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht Trueshopping Ltd - Amazon Marketplace 14/02/2012 09:08:39 RE: Product details enquiry ... <A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht <A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht 

Строки заголовка содержат Sender, ReceivedTime и Subject для почтового элемента.

Добавьте этот макрос в модуль, скопируйте измененный вызов FindInterestingFolders в верхней части моего вызова и запустите его. Почти сразу вы будете предупреждены, что макрос получает доступ к электронным письмам. Вам нужно будет дать разрешение на продолжение макроса и выбрать период для его продолжения. Я предполагаю, что уровень безопасности установлен на Medium, который является стандартным. Если вы настроили его на что-то другое, вы получите разные варианты.

Ответ продолжался ниже кода.

 Sub ExtractHyperLinks2() ' Gets a list of interesting folders. ' Searches the list for mail items with Html bodies that contain an anchor. ' For each such mail item it outputs to the Immediate Window: ' Name of folder (if not already output for an earlier mail item) ' Sender ReceivedTime Subject ' First 60 characters of first anchor ' First 60 characters of second anchor ' First 60 characters of third anchor Dim FolderList() As MAPIFolderDtl Dim FolderNameOutput As Boolean Dim InxFL As Long Dim InxItem As Long Dim PosAnchor As Long Call FindInterestingFolders(FolderList, True, False, "|", _ "Personal Folders|!Family", "Personal Folders|!Tony|Amazon") For InxFL = LBound(FolderList) To UBound(FolderList) FolderNameOutput = False With FolderList(InxFL).Folder For InxItem = 1 To .Items.Count With .Items.Item(InxItem) If .Class = olMail Then If .HtmlBody <> "" Then ' This mail item has an Html body so might have a hyperlink. If InStr(1, LCase(.HtmlBody), "<a ") <> 0 Then ' It has at least one anchor If Not FolderNameOutput Then Debug.Print FolderList(InxFL).NameParent & "|" & _ FolderList(InxFL).Folder.Name FolderNameOutput = True End If Debug.Print " " & .SenderName & " " & _ .ReceivedTime & " " & .Subject PosAnchor = InStr(1, LCase(.HtmlBody), "<a ") Do While PosAnchor <> 0 Debug.Print " " & Mid(.HtmlBody, PosAnchor, 60) PosAnchor = InStr(PosAnchor + 1, LCase(.HtmlBody), "<a ") Loop End If End If End If End With Next End With Next End Sub 

Снова я надеюсь, что это было легко. Я не уверен, насколько полезен следующий макрос. Это был шаг в моем развитии, но он не содержит ничего важного, которое не входит в итоговый макрос. Возможно, вам стоит изучить его, потому что последний макрос будет иметь два важных изменения от Macro 2.

То, что делает Macro 3, это извлечение URL-адресов из тега привязки и отбрасывание тех, которые запускают «mailto:». Html позволяет больше вариантов, чем я допускал, потому что я никогда не видел электронного письма, которое использовало эту гибкость. Возможно, вам придется улучшить код, если ваши электронные письма отличаются от ожидаемых. Вам нужно только один URL-адрес от каждого письма, чтобы вы могли добавить код, чтобы отбросить остальные.

Снова добавьте этот макрос в модуль, скопируйте измененный вызов FindInterestingFolders поверх моего вызова и запустите его. В моей системе последние несколько строк:

  Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from ... http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=11081621 http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=3149571 Trueshopping Ltd - Amazon Marketplace 14/02/2012 09:08:39 RE: Product ... http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=11081621 http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=3149571 

Ответ продолжался ниже кода.

 Sub ExtractHyperLinks3() ' Gets a list of interesting folders. ' Searches the list for mail items with Html bodies that contain an ' acceptable anchor. An acceptable anchor is one for which the url ' does not start "mailto:". ' For each acceptable anchor it outputs to the Immediate Window: ' Name of folder (if not already output for an earlier mail item) ' Sender ReceivedTime Subject (if not already output) ' Url from acceptable anchor Dim FolderList() As MAPIFolderDtl Dim FolderNameOutput As Boolean Dim InxFL As Long Dim InxItem As Long Dim ItemHeaderOutput As Boolean Dim LcHtmlBody As String Dim PosAnchor As Long Dim PosTrailingQuote As Long Dim PosUrl As Long Dim Quote As String Dim Url As String Call FindInterestingFolders(FolderList, True, False, "|", _ "Personal Folders|!Family", "Personal Folders|!Tony|Amazon") For InxFL = LBound(FolderList) To UBound(FolderList) FolderNameOutput = False With FolderList(InxFL).Folder For InxItem = 1 To .Items.Count ItemHeaderOutput = False With .Items.Item(InxItem) If .Class = olMail Then If .HtmlBody <> "" Then ' This mail item has an Html body so might contain hyperlinks. LcHtmlBody = LCase(.HtmlBody) If InStr(1, LcHtmlBody, "<a ") <> 0 Then ' It has at least one anchor PosAnchor = InStr(1, LCase(.HtmlBody), "<a ") Do While PosAnchor <> 0 PosUrl = InStr(PosAnchor, LcHtmlBody, "href=") PosUrl = PosUrl + 5 Quote = Mid(LcHtmlBody, PosUrl, 1) ' Extract quote used in html PosUrl = PosUrl + 1 PosTrailingQuote = InStr(PosUrl, LcHtmlBody, Quote) Url = Mid(.HtmlBody, PosUrl, PosTrailingQuote - PosUrl) If Left(LCase(Url), 7) <> "mailto:" Then ' I am interested in this url If Not FolderNameOutput Then Debug.Print FolderList(InxFL).NameParent & "|" & _ FolderList(InxFL).Folder.Name FolderNameOutput = True End If If Not ItemHeaderOutput Then Debug.Print " " & .SenderName & " " & _ .ReceivedTime & " " & .Subject ItemHeaderOutput = True End If Debug.Print " " & Url End If PosAnchor = InStr(PosTrailingQuote, LCase(.HtmlBody), "<a ") Loop End If End If End If End With Next End With Next End Sub 

Для окончательного макроса я создал рабочий лист в одной из книг, которые я использую для разработки ответов.

В финальном макросе вы найдете утверждение:

  Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls" 

Вам нужно заменить это на путь и имя файла вашей книги.

Вы также найдете это заявление:

  Const WkShtName As String = "URLs" 

Я использовал URL-адреса рабочих листов. Я предлагаю вам начать с создания рабочего листа, подобного моему. После того, как вы заработаете окончательный макрос, вы можете адаптировать его к своим требованиям.

У меня есть четыре столбца на моем листе: имя папки, имя отправителя, время получения и URL. Третий столбец содержит полную дату и время, но я отформатировал его, чтобы отобразить только короткую дату. В вашем вопросе нет ничего, чтобы предложить вам дополнительные колонки. Я подумал, что стоит продемонстрировать, что вы можете сделать, и оставить вас, чтобы удалить код, если это не интересно.

Я думаю, вам нужно будет что-то сделать с Полученным временем. Если вы не переместите обработанные электронные письма из 20 папок, каждый запуск макроса снова добавит полный набор URL-адресов. Существует много способов не обрабатывать электронные письма снова. Например, вы можете добавить категорию пользователя в обработанные электронные письма. Однако я подозреваю, что самый простой подход:

  • Добавьте скрытый рабочий лист в книгу.
  • Установите ячейку A1 этого листа на «Последний обработанный адрес электронной почты» и установите значение B1 до 1 января 2000 года.
  • Добавьте в код, который отбрасывает неинтересные электронные письма, тест для Полученного времени после этой даты / времени.
  • Записывайте последнее полученное время любого обработанного электронного письма.
  • Напишите последнее полученное время любого обработанного письма в ячейку B1 скрытого рабочего листа.

Я включил много комментариев в итоговый макрос, объясняющий, как я накапливаю данные и записываю их на рабочий лист, поэтому я не буду повторять здесь. Я желаю вам удачи и вначале повторю инструкцию, чтобы спросить, не ясно ли что-то.

Снова добавьте этот макрос в модуль, скопируйте измененный вызов FindInterestingFolders в верхней части моего вызова. На этот раз вам также придется обновить один или оба оператора константы перед запуском макроса.

 Sub ExtractHyperLinks() ' Open destination workbook. ' Find last used row in destination worksheet. ' Gets a list of interesting folders. ' Searches the list for mail items with Html bodies that contain an ' acceptable anchor. An acceptable anchor is one for which the url ' does not start "mailto:". ' For each acceptable anchor it outputs to the workbook: ' Column 1 := Name of folder ' Column 2 := Sender ' Column 3 := ReceivedTime ' Column 4 := Url Dim ExcelWkBk As Excel.Workbook Dim FolderList() As MAPIFolderDtl Dim FolderName As String Dim InterestingURL As Boolean Dim InxOutput As Long Dim InxFL As Long Dim InxItem As Long Dim ItemCrnt As MailItem Dim LcHtmlBody As String Dim OutputValue(1 To 50, 1 To 4) Dim PosAnchor As Long Dim PosTrailingQuote As Long Dim PosUrl As Long Dim Quote As String Dim RowNext As Long Dim TargetAddr As String Dim Url As String ' Replace constant value with path and file name of your workbook. Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls" Const WkShtName As String = "URLs" Set ExcelWkBk = Application.CreateObject("Excel.Application"). _ Workbooks.Open(WkBkPathFile) With ExcelWkBk .Application.Visible = True ' Slows the macro but helps during testing With .Worksheets(WkShtName) ' Find last used row in destination worksheet by going to bottom of sheet ' then moving up until a non-empty row is found then going down one. ' .End(xlUp) is VBA equivalent of Ctrl+Up. RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1 End With End With Call FindInterestingFolders(FolderList, True, False, "|", _ "Personal Folders|!Family", "Personal Folders|!Tony|Amazon") InxOutput = 0 For InxFL = LBound(FolderList) To UBound(FolderList) FolderName = FolderList(InxFL).NameParent & "|" & FolderList(InxFL).Folder.Name With FolderList(InxFL).Folder For InxItem = 1 To .Items.Count With .Items.Item(InxItem) If .Class = olMail Then If .HtmlBody <> "" Then ' This mail item has an Html body so might contain hyperlinks. LcHtmlBody = LCase(.HtmlBody) If InStr(1, LcHtmlBody, "<a ") <> 0 Then ' It has at least one anchor PosAnchor = InStr(1, LCase(.HtmlBody), "<a ") Do While PosAnchor <> 0 PosUrl = InStr(PosAnchor, LcHtmlBody, "href=") PosUrl = PosUrl + 5 Quote = Mid(LcHtmlBody, PosUrl, 1) ' Extract quote used in html PosUrl = PosUrl + 1 PosTrailingQuote = InStr(PosUrl, LcHtmlBody, Quote) Url = Mid(.HtmlBody, PosUrl, PosTrailingQuote - PosUrl) InterestingURL = True ' Assume interesting until find otherwise If Left(LCase(Url), 7) = "mailto:" Then InterestingURL = False End If ' ********************************************************** ' Set InterestingURL = False for any other urls you want ' to reject. If you can tell a URL is ininteresting by ' looking at it, you can use code like mine. ' ********************************************************** If InterestingURL Then ' This URL and supporting data is to be output to the ' workbook. ' Rather than output data to the workbook cell by cell, ' which can be slow, I build it up in the array ' OutputValue(1 to 50, 1 To 4). It is normal in a 2D array ' for the first dimension to be for columns and the second ' for rows. Arrays to be read from or written to a worksheet ' are the other way round. You can resize the second ' dimension of a dynamic array but not the first so you ' cannot resize an array being built for a workbook. I ' cannot resize the array so I have fixed its size at ' compile time. ' This code fills the array, writes it out to the workbook ' and resets the array index. I have 50 rows because I ' wanted to test the filling and refilling of the array. I ' would suggest you make it bigger. InxOutput = InxOutput + 1 If InxOutput > UBound(OutputValue, 1) Then ' Array is fill. Output it to workbook TargetAddr = "A" & RowNext & ":D" & _ RowNext + UBound(OutputValue, 1) - 1 ExcelWkBk.Worksheets(WkShtName). _ Range(TargetAddr).Value = OutputValue RowNext = RowNext + 50 InxOutput = 1 End If OutputValue(InxOutput, 1) = FolderName OutputValue(InxOutput, 2) = .SenderName OutputValue(InxOutput, 3) = .ReceivedTime OutputValue(InxOutput, 4) = Url End If PosAnchor = InStr(PosTrailingQuote, LCase(.HtmlBody), "<a") Loop End If End If End If End With Next End With Next ExcelWkBk.Save ' Save changes over the top of the original file. ExcelWkBk.Close (False) ' Don't save changes Set ExcelWkBk = Nothing ' Release resource End Sub 

Ребята Я использую codetwo outlook exporter для выполнения этой задачи. Я как-то наткнулся на это. Спасибо Marc nd Expfresh! ваши решения велики, но я нашел другой способ, прежде чем даже попробовать их. Это здорово, что на этом форуме есть полезные люди. Только для людей, сталкивающихся с одной и той же проблемой: USE CODETWO outlook Exporter. – Работает. привет – Адди

  • Из VBA в Outlook, как мне заморозить панели в Excel?
  • Outlook VBA Вызов макроса Excel
  • Импортировать группу контактов из Outlook - excel vba
  • Вставить конкретный диапазон excel в обзорную встречу
  • Выберите другой почтовый ящик на основе значения ячейки
  • Удалить текст до и после определенной строки по электронной почте (до определенного слова)
  • файл excel не найден при ссылке на ошибку времени выполнения
  • Есть ли способ предотвратить автореволюцию в мировоззрении?
  • Отправка по электронной почте выбранного диапазона в Excel / Outlook
  • Адрес X500 вместо передачи адреса электронной почты отображается при пересылке на лист Excel
  • Отправка сообщения электронной почты из Excel в Outlook
  • Давайте будем гением компьютера.