Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
29.03.2024, 08:45:47

Войти
Хотите поблагодарить участника за дельный совет? Нажмите [Повысить]. Так вы заслуженно поднимите репутацию активному участнику.
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Outlook и VBA
| | |-+  Изменение имени письма при совпадении
Страниц: [1]   Вниз
Печать
Автор Тема: Изменение имени письма при совпадении  (Прочитано 20759 раз)
0 Пользователей и 1 Гость смотрят эту тему.
evgeniygeo
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 13


Просмотр профиля
« : 16.02.2021, 13:15:51 »

Всем привет!
Благодаря данному форуму я смог собрать рабочий код (пусть и не очень лаконичный  Улыбка), который сохраняет все входящие и отправленные письма в папку на диск.
Но не смотря на то, что я прописал наименование файла, как дата и время сохранения, случается, что письма приходят в одну секунду и происходит замена файлов в папке.
Подскажите пожалуйста, как прописать дополнительный индекс "(n)" для одинаковых имен?

spoiler for КОД:
Код: (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

« Последнее редактирование: 17.02.2021, 08:28:00 от Дмитрий Щербаков(The_Prist) » Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #1 : 16.02.2021, 18:39:51 »

Вот здесь я выкладывал подобную функцию: Сохранить вложения из Outlook в указанную папку
Там же видно как её использовать. Называется GetAtchName
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
evgeniygeo
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 13


Просмотр профиля
« Ответ #2 : 17.02.2021, 06:53:24 »

Супер! Большое Спасибо!

spoiler for КОД:
Код: (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
« Последнее редактирование: 17.02.2021, 08:27:39 от Дмитрий Щербаков(The_Prist) » Записан
evgeniygeo
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 13


Просмотр профиля
« Ответ #3 : 19.02.2021, 06:29:17 »

Дмитрий Щербаков(The_Prist),
подскажите пожалуйста, а можно ли подобным способом проверить не папку а архив (zip)?
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #4 : 19.02.2021, 11:44:32 »

Нет. Архив надо будет распаковывать, если речь про то, чтобы добавить в архив файлы без повторений.
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
evgeniygeo
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 13


Просмотр профиля
« Ответ #5 : 19.02.2021, 12:28:09 »

Спасибо! Да, вопрос был об этом  Улыбка
Записан
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru