Новости:

Форум на данный момент в стадии обновления. Если у Вас возникли проблемы со входом в свою учетную запись - просьба писать на email: info@excel-vba.ru

Главное меню

Изменение имени письма при совпадении

Автор evgeniygeo, 16.02.2021, 13:15:51

« назад - далее »
Печать
Вниз Страницы1
Действия пользователя

evgeniygeo

16.02.2021, 13:15:51 Последнее редактирование: 17.02.2021, 08:28:00 от Дмитрий Щербаков(The_Prist)
Всем привет!
Благодаря данному форуму я смог собрать рабочий код (пусть и не очень лаконичный  :)), который сохраняет все входящие и отправленные письма в папку на диск.
Но не смотря на то, что я прописал наименование файла, как дата и время сохранения, случается, что письма приходят в одну секунду и происходит замена файлов в папке.
Подскажите пожалуйста, как прописать дополнительный индекс "(n)" для одинаковых имен?

[spoiler=КОД]
Код (vb) Выделить
Private WithEvents OutboxItems As Outlook.Items
Private WithEvents InboxItems As Outlook.Items
Private WithEvents InboxItems2 As Outlook.Items

Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Dim oIncomingOut As Object
Dim oIncomingIn As Object
Dim oIncomingIn2 As Object
Set xNameSpace = Outlook.Application.Session

Set oIncomingOut = xNameSpace.GetDefaultFolder(5)
Set oIncomingIn = xNameSpace.GetDefaultFolder(6)
Set oIncomingIn2 = xNameSpace.GetDefaultFolder(6).Folders("Руководитель")

Set OutboxItems = oIncomingOut.Items
Set InboxItems = oIncomingIn.Items
Set InboxItems2 = oIncomingIn2.Items
End Sub

Private Sub OutboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Исх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
  x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
x = Replace(x, "image001.png;", "")
x = Replace(x, "image002.png;", "")
x = Replace(x, "image003.png;", "")
x = Replace(x, "image004.png;", "")
x = Replace(x, "image005.png;", "")
x = Replace(x, "image006.png;", "")
x = Replace(x, "image007.png;", "")
x = Replace(x, "image008.png;", "")
x = Replace(x, "image009.png;", "")
x = Replace(x, "image001.jpg;", "")
x = Replace(x, "image002.jpg;", "")
x = Replace(x, "image003.jpg;", "")
x = Replace(x, "image004.jpg;", "")
x = Replace(x, "image005.jpg;", "")
x = Replace(x, "image006.jpg;", "")
x = Replace(x, "image007.jpg;", "")
x = Replace(x, "image008.jpg;", "")
x = Replace(x, "image009.jpg;", "")
x = Replace(x, "image001.jpeg;", "")
x = Replace(x, "image002.jpeg;", "")
x = Replace(x, "image003.jpeg;", "")
x = Replace(x, "image004.jpeg;", "")
x = Replace(x, "image005.jpeg;", "")
x = Replace(x, "image006.jpeg;", "")
x = Replace(x, "image007.jpeg;", "")
x = Replace(x, "image008.jpeg;", "")
x = Replace(x, "image009.jpeg;", "")
x = Replace(x, "image001.gif;", "")
x = Replace(x, "image002.gif;", "")
x = Replace(x, "image003.gif;", "")
x = Replace(x, "image004.gif;", "")
x = Replace(x, "image005.gif;", "")
x = Replace(x, "image006.gif;", "")
x = Replace(x, "image007.gif;", "")
x = Replace(x, "image008.gif;", "")
x = Replace(x, "image009.gif;", "")
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")

   Dim s As String
   Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
       s = xFilePath & "\" & xFileName & ".msg" & vbTab _
       & xMailItem.SentOn & vbTab _
       & xMailItem.ReceivedTime & vbTab _
       & xMailItem.Sender.Name & vbTab _
       & xMailItem.To & vbTab _
       & xMailItem.CC & vbTab _
       & xMailItem.Subject & vbTab _
       & x & vbTab _
       & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
       
   ff = FreeFile
   'Открываем текстовый файл
   'если файла нет - он будет создан
   Open xFilePath & "\Архив.txt" For Append As #ff
   'записываем значение строки в файл
   Print #ff, s
   Close #ff ' Закрываем файл
   
Exit Sub
End Sub

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Вх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
  x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
x = Replace(x, "image001.png;", "")
x = Replace(x, "image002.png;", "")
x = Replace(x, "image003.png;", "")
x = Replace(x, "image004.png;", "")
x = Replace(x, "image005.png;", "")
x = Replace(x, "image006.png;", "")
x = Replace(x, "image007.png;", "")
x = Replace(x, "image008.png;", "")
x = Replace(x, "image009.png;", "")
x = Replace(x, "image001.jpg;", "")
x = Replace(x, "image002.jpg;", "")
x = Replace(x, "image003.jpg;", "")
x = Replace(x, "image004.jpg;", "")
x = Replace(x, "image005.jpg;", "")
x = Replace(x, "image006.jpg;", "")
x = Replace(x, "image007.jpg;", "")
x = Replace(x, "image008.jpg;", "")
x = Replace(x, "image009.jpg;", "")
x = Replace(x, "image001.jpeg;", "")
x = Replace(x, "image002.jpeg;", "")
x = Replace(x, "image003.jpeg;", "")
x = Replace(x, "image004.jpeg;", "")
x = Replace(x, "image005.jpeg;", "")
x = Replace(x, "image006.jpeg;", "")
x = Replace(x, "image007.jpeg;", "")
x = Replace(x, "image008.jpeg;", "")
x = Replace(x, "image009.jpeg;", "")
x = Replace(x, "image001.gif;", "")
x = Replace(x, "image002.gif;", "")
x = Replace(x, "image003.gif;", "")
x = Replace(x, "image004.gif;", "")
x = Replace(x, "image005.gif;", "")
x = Replace(x, "image006.gif;", "")
x = Replace(x, "image007.gif;", "")
x = Replace(x, "image008.gif;", "")
x = Replace(x, "image009.gif;", "")
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")

   Dim s As String
   Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
       s = xFilePath & "\" & xFileName & ".msg" & vbTab _
       & xMailItem.SentOn & vbTab _
       & xMailItem.ReceivedTime & vbTab _
       & xMailItem.Sender.Name & vbTab _
       & xMailItem.To & vbTab _
       & xMailItem.CC & vbTab _
       & xMailItem.Subject & vbTab _
       & x & vbTab _
       & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
       
   ff = FreeFile
   'Открываем текстовый файл
   'если файла нет - он будет создан
   Open xFilePath & "\Архив.txt" For Append As #ff
   'записываем значение строки в файл
   Print #ff, s
   Close #ff ' Закрываем файл
   
Exit Sub
End Sub

Private Sub InboxItems2_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Вх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
  x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
x = Replace(x, "image001.png;", "")
x = Replace(x, "image002.png;", "")
x = Replace(x, "image003.png;", "")
x = Replace(x, "image004.png;", "")
x = Replace(x, "image005.png;", "")
x = Replace(x, "image006.png;", "")
x = Replace(x, "image007.png;", "")
x = Replace(x, "image008.png;", "")
x = Replace(x, "image009.png;", "")
x = Replace(x, "image001.jpg;", "")
x = Replace(x, "image002.jpg;", "")
x = Replace(x, "image003.jpg;", "")
x = Replace(x, "image004.jpg;", "")
x = Replace(x, "image005.jpg;", "")
x = Replace(x, "image006.jpg;", "")
x = Replace(x, "image007.jpg;", "")
x = Replace(x, "image008.jpg;", "")
x = Replace(x, "image009.jpg;", "")
x = Replace(x, "image001.jpeg;", "")
x = Replace(x, "image002.jpeg;", "")
x = Replace(x, "image003.jpeg;", "")
x = Replace(x, "image004.jpeg;", "")
x = Replace(x, "image005.jpeg;", "")
x = Replace(x, "image006.jpeg;", "")
x = Replace(x, "image007.jpeg;", "")
x = Replace(x, "image008.jpeg;", "")
x = Replace(x, "image009.jpeg;", "")
x = Replace(x, "image001.gif;", "")
x = Replace(x, "image002.gif;", "")
x = Replace(x, "image003.gif;", "")
x = Replace(x, "image004.gif;", "")
x = Replace(x, "image005.gif;", "")
x = Replace(x, "image006.gif;", "")
x = Replace(x, "image007.gif;", "")
x = Replace(x, "image008.gif;", "")
x = Replace(x, "image009.gif;", "")
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")

   Dim s As String
   Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
       s = xFilePath & "\" & xFileName & ".msg" & vbTab _
       & xMailItem.SentOn & vbTab _
       & xMailItem.ReceivedTime & vbTab _
       & xMailItem.Sender.Name & vbTab _
       & xMailItem.To & vbTab _
       & xMailItem.CC & vbTab _
       & xMailItem.Subject & vbTab _
       & x & vbTab _
       & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
   
    ff = FreeFile
   'Открываем текстовый файл
   'если файла нет - он будет создан
   Open xFilePath & "\Архив.txt" For Append As #ff
   'записываем значение строки в файл
   Print #ff, s
   Close #ff ' Закрываем файл
   
Exit Sub
End Sub

[/spoiler]

Дмитрий Щербаков(The_Prist)

#1
16.02.2021, 18:39:51
Вот здесь я выкладывал подобную функцию: Сохранить вложения из Outlook в указанную папку
Там же видно как её использовать. Называется GetAtchName
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...

evgeniygeo

#2
17.02.2021, 06:53:24 Последнее редактирование: 17.02.2021, 08:27:39 от Дмитрий Щербаков(The_Prist)
Супер! Большое Спасибо!

[spoiler=КОД]
Код (vb) Выделить
Private WithEvents OutboxItems As Outlook.Items
Private WithEvents InboxItems As Outlook.Items
Private WithEvents InboxItems2 As Outlook.Items

Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Dim oIncomingOut As Object
Dim oIncomingIn As Object
Dim oIncomingIn2 As Object
Set xNameSpace = Outlook.Application.Session

Set oIncomingOut = xNameSpace.GetDefaultFolder(5)
Set oIncomingIn = xNameSpace.GetDefaultFolder(6)
Set oIncomingIn2 = xNameSpace.GetDefaultFolder(6).Folders("Руководитель")

Set OutboxItems = oIncomingOut.Items
Set InboxItems = oIncomingIn.Items
Set InboxItems2 = oIncomingIn2.Items
End Sub

Private Sub OutboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
Dim s As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Исх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
  x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
x = Replace(x, "image001.png;", "")
x = Replace(x, "image002.png;", "")
x = Replace(x, "image003.png;", "")
x = Replace(x, "image004.png;", "")
x = Replace(x, "image005.png;", "")
x = Replace(x, "image006.png;", "")
x = Replace(x, "image007.png;", "")
x = Replace(x, "image008.png;", "")
x = Replace(x, "image009.png;", "")
x = Replace(x, "image001.jpg;", "")
x = Replace(x, "image002.jpg;", "")
x = Replace(x, "image003.jpg;", "")
x = Replace(x, "image004.jpg;", "")
x = Replace(x, "image005.jpg;", "")
x = Replace(x, "image006.jpg;", "")
x = Replace(x, "image007.jpg;", "")
x = Replace(x, "image008.jpg;", "")
x = Replace(x, "image009.jpg;", "")
x = Replace(x, "image001.jpeg;", "")
x = Replace(x, "image002.jpeg;", "")
x = Replace(x, "image003.jpeg;", "")
x = Replace(x, "image004.jpeg;", "")
x = Replace(x, "image005.jpeg;", "")
x = Replace(x, "image006.jpeg;", "")
x = Replace(x, "image007.jpeg;", "")
x = Replace(x, "image008.jpeg;", "")
x = Replace(x, "image009.jpeg;", "")
x = Replace(x, "image001.gif;", "")
x = Replace(x, "image002.gif;", "")
x = Replace(x, "image003.gif;", "")
x = Replace(x, "image004.gif;", "")
x = Replace(x, "image005.gif;", "")
x = Replace(x, "image006.gif;", "")
x = Replace(x, "image007.gif;", "")
x = Replace(x, "image008.gif;", "")
x = Replace(x, "image009.gif;", "")
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")

   Dim k As String
   Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
       k = xFilePath & "\" & xFileName & ".msg" & vbTab _
       & xMailItem.SentOn & vbTab _
       & xMailItem.ReceivedTime & vbTab _
       & xMailItem.Sender.Name & vbTab _
       & xMailItem.To & vbTab _
       & xMailItem.CC & vbTab _
       & xMailItem.Subject & vbTab _
       & x & vbTab _
       & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
       
   ff = FreeFile
   'Открываем текстовый файл
   'если файла нет - он будет создан
   Open xFilePath & "\Архив.txt" For Append As #ff
   'записываем значение строки в файл
   Print #ff, k
   Close #ff ' Закрываем файл
   
Exit Sub
End Sub

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Исх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
  x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
x = Replace(x, "image001.png;", "")
x = Replace(x, "image002.png;", "")
x = Replace(x, "image003.png;", "")
x = Replace(x, "image004.png;", "")
x = Replace(x, "image005.png;", "")
x = Replace(x, "image006.png;", "")
x = Replace(x, "image007.png;", "")
x = Replace(x, "image008.png;", "")
x = Replace(x, "image009.png;", "")
x = Replace(x, "image001.jpg;", "")
x = Replace(x, "image002.jpg;", "")
x = Replace(x, "image003.jpg;", "")
x = Replace(x, "image004.jpg;", "")
x = Replace(x, "image005.jpg;", "")
x = Replace(x, "image006.jpg;", "")
x = Replace(x, "image007.jpg;", "")
x = Replace(x, "image008.jpg;", "")
x = Replace(x, "image009.jpg;", "")
x = Replace(x, "image001.jpeg;", "")
x = Replace(x, "image002.jpeg;", "")
x = Replace(x, "image003.jpeg;", "")
x = Replace(x, "image004.jpeg;", "")
x = Replace(x, "image005.jpeg;", "")
x = Replace(x, "image006.jpeg;", "")
x = Replace(x, "image007.jpeg;", "")
x = Replace(x, "image008.jpeg;", "")
x = Replace(x, "image009.jpeg;", "")
x = Replace(x, "image001.gif;", "")
x = Replace(x, "image002.gif;", "")
x = Replace(x, "image003.gif;", "")
x = Replace(x, "image004.gif;", "")
x = Replace(x, "image005.gif;", "")
x = Replace(x, "image006.gif;", "")
x = Replace(x, "image007.gif;", "")
x = Replace(x, "image008.gif;", "")
x = Replace(x, "image009.gif;", "")
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")

   Dim k As String
   Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
       k = xFilePath & "\" & xFileName & ".msg" & vbTab _
       & xMailItem.SentOn & vbTab _
       & xMailItem.ReceivedTime & vbTab _
       & xMailItem.Sender.Name & vbTab _
       & xMailItem.To & vbTab _
       & xMailItem.CC & vbTab _
       & xMailItem.Subject & vbTab _
       & x & vbTab _
       & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
       
   ff = FreeFile
   'Открываем текстовый файл
   'если файла нет - он будет создан
   Open xFilePath & "\Архив.txt" For Append As #ff
   'записываем значение строки в файл
   Print #ff, k
   Close #ff ' Закрываем файл
   
Exit Sub
End Sub

Private Sub InboxItems2_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Исх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
  x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
x = Replace(x, "image001.png;", "")
x = Replace(x, "image002.png;", "")
x = Replace(x, "image003.png;", "")
x = Replace(x, "image004.png;", "")
x = Replace(x, "image005.png;", "")
x = Replace(x, "image006.png;", "")
x = Replace(x, "image007.png;", "")
x = Replace(x, "image008.png;", "")
x = Replace(x, "image009.png;", "")
x = Replace(x, "image001.jpg;", "")
x = Replace(x, "image002.jpg;", "")
x = Replace(x, "image003.jpg;", "")
x = Replace(x, "image004.jpg;", "")
x = Replace(x, "image005.jpg;", "")
x = Replace(x, "image006.jpg;", "")
x = Replace(x, "image007.jpg;", "")
x = Replace(x, "image008.jpg;", "")
x = Replace(x, "image009.jpg;", "")
x = Replace(x, "image001.jpeg;", "")
x = Replace(x, "image002.jpeg;", "")
x = Replace(x, "image003.jpeg;", "")
x = Replace(x, "image004.jpeg;", "")
x = Replace(x, "image005.jpeg;", "")
x = Replace(x, "image006.jpeg;", "")
x = Replace(x, "image007.jpeg;", "")
x = Replace(x, "image008.jpeg;", "")
x = Replace(x, "image009.jpeg;", "")
x = Replace(x, "image001.gif;", "")
x = Replace(x, "image002.gif;", "")
x = Replace(x, "image003.gif;", "")
x = Replace(x, "image004.gif;", "")
x = Replace(x, "image005.gif;", "")
x = Replace(x, "image006.gif;", "")
x = Replace(x, "image007.gif;", "")
x = Replace(x, "image008.gif;", "")
x = Replace(x, "image009.gif;", "")
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")

   Dim k As String
   Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
       k = xFilePath & "\" & xFileName & ".msg" & vbTab _
       & xMailItem.SentOn & vbTab _
       & xMailItem.ReceivedTime & vbTab _
       & xMailItem.Sender.Name & vbTab _
       & xMailItem.To & vbTab _
       & xMailItem.CC & vbTab _
       & xMailItem.Subject & vbTab _
       & x & vbTab _
       & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
       
   ff = FreeFile
   'Открываем текстовый файл
   'если файла нет - он будет создан
   Open xFilePath & "\Архив.txt" For Append As #ff
   'записываем значение строки в файл
   Print #ff, k
   Close #ff ' Закрываем файл
   
Exit Sub
End Sub

Function GetAtchName(ByVal s As String)
   Dim s1 As String, s2 As String, sEx As String
   Dim lu As Long, lp As Long

   s1 = s
   lp = InStrRev(s, ".", -1, 1)
   If lp Then
       sEx = Mid(s, lp)
       s1 = Mid(s, 1, lp - 1)
   End If
   s2 = s
   lu = 0
   Do While (Dir(s2, 16) <> "")
       lu = lu + 1
       s2 = s1 & "(" & lu & ")" & sEx
   Loop
   GetAtchName = s2
End Function
[/spoiler]

evgeniygeo

#3
19.02.2021, 06:29:17
Дмитрий Щербаков(The_Prist),
подскажите пожалуйста, а можно ли подобным способом проверить не папку а архив (zip)?

Дмитрий Щербаков(The_Prist)

#4
19.02.2021, 11:44:32
Нет. Архив надо будет распаковывать, если речь про то, чтобы добавить в архив файлы без повторений.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...

evgeniygeo

#5
19.02.2021, 12:28:09
Спасибо! Да, вопрос был об этом  :)
Печать
Вверх Страницы1
Действия пользователя
Яндекс.Метрика Рейтинг@Mail.ru