Последние ответы: evgeniygeo

Просмотр сообщений
Страниц: [1]

Основные форумы / Вопросы по Word и VBA / Изменение связей макросом

: 15.07.2021, 08:04:35

Привет!
Нашел на просторах интернета макрос, с помощью которого я могу изменить связь с одного файла на другой. Но к сожалению, он убирает галочку "Сохранять формат при обновлении" и все форматы после обновления слетают. Подскажите пожалуйста, возможно ли ее добавить в коде?

Код: (vb)

Sub changeSource()

Dim dlgSelectFile As FileDialog  'FileDialog object
Dim thisField As Field
Dim selectedFile As Variant    'must be Variant to contain filepath of selected item
Dim newFile As Variant
Dim fieldCount As Integer

On Error Resume Next

'create FileDialog object as File Picker dialog box
Set dlgSelectFile = Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)



With dlgSelectFile
'use Show method to display File Picker dialog box and return user's action
    If .Show = -1 Then

        'step through each string in the FileDialogSelectedItems collection
        For Each selectedFile In .SelectedItems
            newFile = selectedFile    'gets new filepath
        Next selectedFile
    Else   'user clicked cancel
    End If
End With
Set dlgSelectFile = Nothing



'update fields
fieldCount = ActiveDocument.Fields.Count
For x = 1 To fieldCount
    ActiveDocument.Fields(x).LinkFormat.SourceFullName = newFile
Next x

End Sub

2	Основные форумы / Вопросы по Outlook и VBA / Re:Изменение имени письма при совпадении	: 19.02.2021, 12:28:09
Спасибо! Да, вопрос был об этом

3	Основные форумы / Вопросы по Outlook и VBA / Re:Изменение имени письма при совпадении	: 19.02.2021, 06:29:17
Дмитрий Щербаков(The_Prist), подскажите пожалуйста, а можно ли подобным способом проверить не папку а архив (zip)?

Основные форумы / Вопросы по Outlook и VBA / Re:Изменение имени письма при совпадении

: 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

Основные форумы / Вопросы по Outlook и VBA / Изменение имени письма при совпадении

: 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

Основные форумы / Вопросы по Outlook и VBA / Re:Сохранение всех входящих и исходящих писем из Outlook в папку

: 11.02.2021, 13:26:37

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

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

Код: (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

    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 _
        & Replace(x, "image001.png; image002.jpg; ", "") & 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

    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 _
        & Replace(x, "image001.png; image002.jpg; ", "") & 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

    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 _
        & Replace(x, "image001.png; image002.jpg; ", "") & 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

Основные форумы / Вопросы по Outlook и VBA / Re:Сохранение всех входящих и исходящих писем из Outlook в папку

: 11.02.2021, 07:45:19

Пытаюсь использовать Ваш код, но почему-то не срабатывает или я опять все делаю не так(

Код: (vb)

Private Sub Application_NewMail()
Call Items_DoSomthing
End Sub

Sub Items_DoSomthing(Item As MailItem)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
    MessageInfo = "" & _
        "Sender : " & Item.SenderEmailAddress & vbCrLf & _
        "Sent : " & Item.SentOn & vbCrLf & _
        "Received : " & Item.ReceivedTime & vbCrLf & _
        "Subject : " & Item.Subject & vbCrLf & _
        "Size : " & Item.Size & vbCrLf & _
        "Message Body : " & vbCrLf & Item.Body
    Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub

Основные форумы / Вопросы по Outlook и VBA / Re:Сохранение всех входящих и исходящих писем из Outlook в папку

: 10.02.2021, 19:10:17

У меня отлично работает вот этот код https://www.tachytelic.net/2017/10/how-to-run-a-vba-macro-when-new-mail-is-received-in-outlook/
Но я не могу применить его для себя

Код: (vb)

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
  Dim outlookApp As Outlook.Application
  Dim objectNS As Outlook.NameSpace
  
  Set outlookApp = Outlook.Application
  Set objectNS = outlookApp.GetNamespace("MAPI")
  Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
    MessageInfo = "" & _
        "Sender : " & Item.SenderEmailAddress & vbCrLf & _
        "Sent : " & Item.SentOn & vbCrLf & _
        "Received : " & Item.ReceivedTime & vbCrLf & _
        "Subject : " & Item.Subject & vbCrLf & _
        "Size : " & Item.Size & vbCrLf & _
        "Message Body : " & vbCrLf & Item.Body
    Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub

Основные форумы / Вопросы по Outlook и VBA / Re:Сохранение всех входящих и исходящих писем из Outlook в папку

: 10.02.2021, 18:27:35

Попробовал сделать так, но не работает(

Код: (vb)

Private Sub Application_NewMail()

On Error Resume Next

'Get a reference to the first item in the inbox
Dim olObject As Object
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetFirst()

'Exit the sub if there is nothing in the inbox. An error will probably be thrown when using the GetFirst method but check anyway
If olObject Is Nothing Then Exit Sub

'Exit the sub if it's not a mail item or appointment item
If Not TypeOf olObject Is Outlook.MailItem And Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub

'Set the path to your desktop folder here
sFolder = "C:\Users\s1200134\Documents\MyEmails\"

'Save the email to some destination
olObject.SaveAs sFolder & Format(Now(), "yyyy-mm-dd hh_NN_ss") & ".msg", olMsg

Set olObject = Nothing

Exit Sub
End Sub

10	Основные форумы / Вопросы по Outlook и VBA / Re:Сохранение всех входящих и исходящих писем из Outlook в папку	: 10.02.2021, 07:33:52
Пытался поправить по Вашему примеру в статье: https://www.excel-vba.ru/chto-umeet-excel/soxranit-vlozheniya-iz-outlook-v-papku/ Но видимо что-то делаю не так Код: (vb) Sub Application_Startup() Dim xNameSpace As Outlook.NameSpace Dim oIncomingOut As Object Dim oIncomingIn As Object Set xNameSpace = Outlook.Application.Session Set oIncomingOut = xNameSpace.GetDefaultFolder(5) Set oIncomingIn = xNameSpace.GetDefaultFolder(6) Set OutboxItems = oIncomingOut.Items Set InboxItems = oIncomingIn.Items End Sub

Основные форумы / Вопросы по Outlook и VBA / Re:Сохранение всех входящих и исходящих писем из Outlook в папку

: 10.02.2021, 06:49:34

У меня получилось их совместить вот так. Осталась только проблема с глубиной. Сейчас он не просматривает подпапки, что очень важно.

Код: (vb)

Private WithEvents OutboxItems As Outlook.Items
Private WithEvents InboxItems As Outlook.Items

Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set OutboxItems = xNameSpace.GetDefaultFolder(olFolderSentMail).Items
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).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 = xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If
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 = xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If
Exit Sub
End Sub

Основные форумы / Вопросы по Outlook и VBA / Re:Сохранение всех входящих и исходящих писем из Outlook в папку

: 09.02.2021, 18:23:00

В итоге сделал вот так и работает

Только я не понимаю, как их можно совместить?

Код: (vb)

Private WithEvents OutboxItems As Outlook.Items
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set OutboxItems = xNameSpace.GetDefaultFolder(olFolderSentMail).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 = xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If
Exit Sub
End Sub

Основные форумы / Вопросы по Outlook и VBA / Сохранение всех входящих и исходящих писем из Outlook в папку

: 09.02.2021, 12:45:17

Добрый день!

Мне необходимо сохранять все входящие и исходящие сообщения в папку в формате ".msg".
На просторах интернета я нашел и слегка поправил код ниже. Но он работает только с входящими сообщениями, не просматривает подпапки и заменяет сообщения с одинаковой темой.
Возможно кто-то сталкивался с подобным и может подсказать, как поправить код под данную задачку?

Код: (vb)

Private WithEvents InboxItems As Outlook.Items
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
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 = xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMSG
End If
Exit Sub
End Sub

Страниц: [1]