Существуют и другие возможности, но я считаю, что ошибки памяти являются результатом создания объектов Word, а не их закрытия.Om3r попросил дополнительную информацию, но вы проигнорировали его просьбы, что сделало невозможным дать точный ответ.Однако я хотел доказать, что можно без проблем извлекать вложения из большого количества электронных писем, поэтому я сделал несколько предположений.
Я понимаю, почему вам нужна подпрограмма, которая будет сканировать вашу папку «Входящие» на наличие отставания в 8000камера подачи писем.Я не понимаю, почему вы хотите использовать событие для мониторинга вашего почтового ящика.Я не могу поверить, что это срочная задача.Почему бы не запустить сканирование один или два раза в день?Тем не менее, подпрограмма, которую я написал, может быть адаптирована для создания макроса, вызываемого подпрограммой события.Мой текущий код опирается на глобальные переменные, которые вам придется заменить на локальные переменные.Я не фанат глобальных переменных, но я не хотел создавать ссылку на папку для каждого вызова внутренней подпрограммы, и список параметров для макроса, который может вызываться подпрограммой события, исправлен.
Комупротестировав код, который я планировал создать, я сначала сгенерировал 790 электронных писем, которые соответствовали (я надеюсь) вашим сообщениям с камеры.Я планировал создать больше, но я думаю, что мой интернет-провайдер классифицировал меня как спаммера или, возможно, флеймора, и это не позволило бы мне отправлять больше.Тело этих писем выглядело так:
xxx Preamble xxx ‹cr›‹lf›|
Exact Submission Timestamp: 2019-02-22 15:00:00 ‹cr›‹lf›|
xxx Postamble xxx ‹cr›‹lf›|
В вашем коде требуется строка «Точная временная метка отправки:», за которой следует дата, которую вы используете в качестве имени файла.Я предположил эту дату в формате, который VBA может распознать как дату, и я предположил, что дата заканчивается стандартной новой строкой Windows (возврат каретки, перевод строки).Второе предположение будет легко изменить.У меня есть подпрограмма, которая будет принимать гораздо больше форматов дат, чем CDate VBA, которые я могу предоставить при необходимости.
Каждое письмо имеет разные дату и время в период с ноября 2018 года по февраль 2019 года.
Я бы никогда не сохранил 8000 файлов в одной папке на диске.Даже с несколькими сотнями файлов в папке становится трудно найти тот, который вы хотите.Моя корневая папка - «C: \ DataArea \ Test», но вы можете легко это изменить.Учитывая временную метку в моем примере электронного письма, моя подпрограмма проверила бы наличие папки «C: \ DataArea \ Test \ 2019», затем «C: \ DataArea \ Test \ 2019 \ 02» и, наконец, «C: \ DataArea \ Test \ 2019 \ 02».\ 22” .Если папка не существует, она будет создана.Вложение затем сохраняется во внутренней папке.Мой код может быть легко адаптирован для сохранения файлов на уровне месяца или часа, в зависимости от того, сколько из этих файлов вы получаете в месяц, день или час.
Моя процедура проверяет каждую электронную почту в папке «Входящие» на наличие строки «Точная временная метка представления: »с последующей датой.Если он находит их, он проверяет вложение с расширением JPG.Если электронная почта проходит все эти тесты, вложение сохраняется в соответствующей папке на диске, и электронная почта перемещается из папки «Входящие» Outlook в «CameraFeeds1».Причины перемещения электронного письма: (1) он очищает папку «Входящие» и (2) вы можете запускать процедуру так часто, как пожелаете, не находя уже обработанное электронное письмо.Я назвал папку назначения «CameraFeeds1», потому что вы написали, что хотите поработать над этими электронными письмами.Я думал, что вы можете переместить электронные письма в папку «CameraFeeds2», как только закончите эту дальнейшую работу.
Я предполагал, что обработка 790 или 8 000 электронных писем займет много времени.В моем тесте продолжительность оказалась не такой плохой, как я ожидал;790 электронных писем заняли около полутора минут.Тем не менее, я создал пользовательскую форму, чтобы показать прогресс.Я не могу включить форму в свой ответ, поэтому вам придется создать свою собственную.Моя выглядит так:
Внешний вид не важен.Важным является имя формы и четыре элемента управления в форме:
- Имя формы: frmSaveCameraFeeds
- Имя TextBox: txtCountCrnt
- Имя TextBox: txtCountMax
- Имя CommandButton: cmdStart
- Имя CommandButton: cmdStop
Если вы запустите макрос StartSaveCameraFeeds, он загрузит эту форму.Нажмите [Пуск], чтобы начать процесс сохранения.Вы можете разрешить запуск макроса до тех пор, пока он не проверит каждое электронное письмо в папке «Входящие», или вы можете нажать [Стоп] в любое время.Кнопка Стоп не так важна, как я боялся.Я думал, что рутина может занять несколько часов, но это не так.
Вы не сообщаете, где находятся ваши 8000 электронных писем.У меня есть Входящие для каждой учетной записи плюс Входящие по умолчанию, которые я использую только для тестирования.Я переместил 790 тестовых писем в папку «Входящие» по умолчанию и использовал GetDefaultFolder для ссылки на него.Я предполагаю, что вы знаете, как ссылаться на другую папку, если это необходимо.Обратите внимание, я использую Session вместо пространства имен.Предполагается, что эти два метода эквивалентны, но я всегда использую Session, потому что это проще и потому что у меня когда-то была ошибка с пространством имен, которое я не мог диагностировать.Я ссылаюсь на папку «CameraFeeds1» относительно папки «Входящие».
Вам придется откорректировать мой код хотя бы частично.Для минимальных изменений сделайте следующее:
Создайте новый модуль и скопируйте в него этот код:
Option Explicit
Public Const Marker As String = "Exact Submission Timestamp: "
Public Const RootSave As String = "C:\DataArea\Test"
Public FldrIn As Outlook.Folder
Public FldrOut As Outlook.Folder
Sub StartSaveCameraFeeds()
' Reference outlook folders then pass control to frmSaveCameraFeeds
Set FldrIn = Session.GetDefaultFolder(olFolderInbox)
Set FldrOut = FldrIn.Parent.Folders("CameraFeeds1")
Load frmSaveCameraFeeds
With frmSaveCameraFeeds
.Caption = "Saving jpg files from Camera feed emails"
.txtCountCrnt = 0
.txtCountMax = FldrIn.Items.Count
.Show vbModal
End With
' Form unloaded by cmdStop within form
Set FldrIn = Nothing
Set FldrOut = Nothing
End Sub
Public Sub SaveCameraFeed(ByRef ItemCrnt As MailItem)
' Checks a single mail item to be a "camera feed" email. If the mail item is
' a "camera feed" email, it saves the JPG file using the date within the
' email body as the file name. If the mail item is not a "camera feed"
' email, it does nothing.
' To be a camera feed mail item:
' * The text body must contain a string of the form: "xxxyyyy" & vbCr & vbLf
' where "xxx" matches the public constant Marker and "yyy" is recognised
' by VBA as a date
' * It must have an attachment with an extension of "JPG" or "jpg".
' If the mail item is a camera feed email:
' * In "yyy" any colons are replaced by understores.
' * The JPG attachment is saved with the name yyy & ".jpg"
Dim DateCrnt As Date
Dim DateStr As String
Dim DayCrnt As String
Dim InxA As Long
Dim MonthCrnt As String
Dim PathFileName As String
Dim PosEnd As Long
Dim PosStart As Long
Dim SomethingToSave As Boolean
Dim YearCrnt As String
SomethingToSave = False ' Assume no JPG to save until find otherwise
With ItemCrnt
PosStart = InStr(1, .Body, Marker)
If PosStart > 0 Then
PosStart = PosStart + Len(Marker)
PosEnd = InStr(PosStart, .Body, vbCr & vbLf)
DateStr = Mid$(.Body, PosStart, PosEnd - PosStart)
If IsDate(DateStr) Then
DateCrnt = DateStr
For InxA = 1 To .Attachments.Count
If LCase(Right$(.Attachments(InxA).Filename, 4)) = ".jpg" Then
SomethingToSave = True
Exit For
End If
Next
End If
End If
If SomethingToSave Then
DateStr = Replace(DateStr, ":", "_")
YearCrnt = Year(DateCrnt)
MonthCrnt = Month(DateCrnt)
DayCrnt = Day(DateCrnt)
Call CreateDiscFldrIfItDoesntExist(RootSave, YearCrnt, MonthCrnt, DayCrnt)
PathFileName = RootSave & "\" & YearCrnt & "\" & MonthCrnt & "\" & DayCrnt & _
"\" & Trim(DateStr) & ".jpg"
.Attachments(InxA).SaveAsFile PathFileName
.Move FldrOut
End If
End With
End Sub
Public Sub CreateDiscFldrIfItDoesntExist(ByVal Root As String, _
ParamArray SubFldrs() As Variant)
' If a specified disk folder (not an Outlook folder) does not exist, create it.
' Root A disk folder which must exist and for which the user
' must have write permission.
' SubFldrs A list of sub-folders required within folder Root.
' Example call: CreateDiscFldrsIfNecessary("C:\DataArea", "Aaa", "Bbb", "Ccc")
' Result: Folder "C:\DataArea\Aaa\Bbb\Ccc" will be created if it does not already exist.
' Note: MkDir("C:\DataArea\Aaa\Bbb\Ccc") fails unless folder "C:\DataArea\Aaa\Bbb" exists.
Dim Filename As String
Dim Fldrname As String
Dim InxSF As Long
Fldrname = Root
For InxSF = LBound(SubFldrs) To UBound(SubFldrs)
Fldrname = Fldrname & "\" & SubFldrs(InxSF)
If Not PathExists(Fldrname) Then
Call MkDir(Fldrname)
End If
Next
End Sub
Public Function PathExists(ByVal Pathname As String) As Boolean
' Returns True if path exists
' Coded by Tony Dallimore
' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283
On Error Resume Next
PathExists = ((GetAttr(Pathname) And vbDirectory) = vbDirectory)
On Error GoTo 0
End Function
Я должен предупредить вас, что у меня есть модули, полные стандартных подпрограмм, которые я используювсе время.Я считаю, что я включил все стандартные процедуры, используемые в коде, который я написал для вас.Если код не работает из-за отсутствия подпрограммы или функции, оставьте комментарий, и я извинюсь и добавлю отсутствующий макрос в мой код.
В верхней части приведенного выше кода есть Public Const RootSave As String = "C:\DataArea\Test".Вам придется изменить это, чтобы ссылаться на вашу корневую папку.
Первый оператор Sub StartSaveCameraFeeds() - это Set FldrIn = Session.GetDefaultFolder(olFolderInbox).При необходимости измените это, если электронные письма не находятся в папке «Входящие» по умолчанию.
В теле Sub StartSaveCameraFeeds() вы найдете PosEnd = InStr(PosStart, .Body, vbCr & vbLf).Если строка даты не заканчивается стандартной новой строкой Windows, при необходимости измените этот оператор.
Создайте форму пользователя.Добавьте два текстовых поля и две кнопки CommandButton.Назовите их, как определено выше.Скопируйте приведенный ниже код в область кода формы:
Option Explicit
Private Sub cmdStart_Click()
' Call SaveCameraFeed for every MailItem in FldrIn
Dim CountMax As Long
Dim InxI As Long
Dim MailItemCrnt As MailItem
With FldrIn
CountMax = FldrIn.Items.Count
For InxI = CountMax To 1 Step -1
If .Items(InxI).Class = olMail Then
Set MailItemCrnt = .Items(InxI)
Call SaveCameraFeed(MailItemCrnt)
Set MailItemCrnt = Nothing
End If
txtCountCrnt = CountMax - InxI + 1
DoEvents
Next
End With
Unload Me
End Sub
Private Sub cmdStop_Click()
Unload Me
End Sub
Код формы не нуждается в исправлении.
Как я уже писал, этот код обрабатывал 790 электронных писем с камеры в примернополторы минуты.Я запрограммировал еще одну процедуру, которая проверяла, что для каждого электронного письма дата соответствует имени файла jpg.Я мог бы включить эту процедуру в свой ответ, если вы хотите выполнить ту же проверку.