Добрый день! Благодаря The_Prist(Щербакову Дмитрию) я нашел в интернете код, который архивирует файлы с помощью встроенного в windows архиватора. Но при использовании данного кода отображается процесс архивации, который жутко напрягает. Подскажите пожалуйста, как скрыть данное окно?
Код
'---------------------------------------------------------------------------------------
' Procedure : CreateNewZip
' DateTime : 03.08.2014 21:55
' Author : The_Prist(Щербаков Дмитрий)
' http://www.excel-vba.ru
' Purpose : Основная процедура создания пустого ZIP-архива
'---------------------------------------------------------------------------------------
Sub CreateNewZip(sPath As String)
If Dir(sPath) <> "" Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
'---------------------------------------------------------------------------------------' Procedure : ZIPOneFile
' Author : The_Prist(Щербаков Дмитрий)
' http://www.excel-vba.ru
' Purpose : Создание архива из одного файла или добавление в уже существующий архив нового файла
' sZIPFileName - полный путь к файлу создаваемого архива
' sFileToZIP - полный путь к файлу для архивации
'---------------------------------------------------------------------------------------
Function ZIPOneFile(sZIPFileName As String, sFileToZIP As String)
Dim objShell As Object
Dim lcnt As Long
Set objShell = CreateObject("Shell.Application")
'создаем пустой ZIP-архив, если его еще нет
If Dir(sZIPFileName, 16) = "" Then
CreateNewZip (sZIPFileName)
End If
lcnt = objShell.Namespace((sZIPFileName)).Items.Count
'помещаем файлы из папки в архив
objShell.Namespace((sZIPFileName)).CopyHere CStr(sFileToZIP)
'дожидаемся окончания архивации
Do Until objShell.Namespace((sZIPFileName)).Items.Count = lcnt + 1
DoEvents
Loop
End Function
Sub ToRarExample()
Call ZIPOneFile("C:\Documents\Архив\Test.zip", "C:\Test.xls")
End Sub
evgeniygeo, не перебарщивайте с самокритикой, ни к чему это. Исходя из
Цитата
Return value This method does not return a value.
, можно сделать вывод, что CopyHere - это процедура. Следовательно скобки при её вызове не нужны. Одна из дурацких особенностей VBA. Причём да, если аргумент в процедуру передаётся один, то это как бы претензий у компилятора не вызывает Учитывая то, что вы не часто кодите, то о такой особенности - можете и не знать. А вот о чём вам выдаётся сообщение - лучше всегда приводить полностью - это единственное за что вас можно пожурить.
Андрей VG, к сожалению, процесс сжатия все равно отображается
вот полный код, возможно пригодится:
Код
Private WithEvents OutboxItems As Outlook.Items
Private WithEvents InboxItems As Outlook.Items
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
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 = Environ("temp")
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, "")
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
m = Replace(s, xFilePath & "\", "")
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
Call ZIPOneFile(xFilePath & "\MyEmails.zip", s)
'Kill s
End If
For j = 1 To xMailItem.Attachments.Count
x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
For n = 1 To 9
x = Replace(x, "image00" & n & ".png;", "")
x = Replace(x, "image00" & n & ".jpg;", "")
x = Replace(x, "image00" & n & ".jpeg;", "")
x = Replace(x, "image00" & n & ".gif;", "")
Next
For n = 10 To 99
x = Replace(x, "image0" & n & ".png;", "")
x = Replace(x, "image0" & n & ".jpg;", "")
x = Replace(x, "image0" & n & ".jpeg;", "")
x = Replace(x, "image0" & n & ".gif;", "")
Next
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")
Dim k As String
Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
k = m & 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
Dim s As String
On Error Resume Next
xFilePath = Environ("temp")
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, "")
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
m = Replace(s, xFilePath & "\", "")
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
Call ZIPOneFile(xFilePath & "\MyEmails.zip", s)
'Kill s
End If
For j = 1 To xMailItem.Attachments.Count
x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
For n = 1 To 9
x = Replace(x, "image00" & n & ".png;", "")
x = Replace(x, "image00" & n & ".jpg;", "")
x = Replace(x, "image00" & n & ".jpeg;", "")
x = Replace(x, "image00" & n & ".gif;", "")
Next
For n = 10 To 99
x = Replace(x, "image0" & n & ".png;", "")
x = Replace(x, "image0" & n & ".jpg;", "")
x = Replace(x, "image0" & n & ".jpeg;", "")
x = Replace(x, "image0" & n & ".gif;", "")
Next
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")
Dim k As String
Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
k = m & 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
Function ZIPOneFile(sZIPFileName As String, sFileToZIP As String)
Dim objShell As Object
Dim lcnt As Long
Set objShell = CreateObject("Shell.Application")
'создаем пустой ZIP-архив, если его еще нет
If Dir(sZIPFileName, 16) = "" Then
CreateNewZip (sZIPFileName)
End If
lcnt = objShell.NameSpace((sZIPFileName)).Items.Count
'помещаем файлы из папки в архив
objShell.NameSpace((sZIPFileName)).CopyHere CStr(sFileToZIP), 4
'дожидаемся окончания архивации
Do Until objShell.NameSpace((sZIPFileName)).Items.Count = lcnt + 1
DoEvents
Loop
End Function
Sub CreateNewZip(sPath As String)
If Dir(sPath) <> "" Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Попробуйте сначала перемещать файлы во временную папку, а из неё уже создавать архив. Помню была подобная проблема при извлечении. Не знаю, поможет ли при архивации. Что-то вроде:
Код
lcnt = objShell.NameSpace((sZIPFileName)).Items.Count
'помещаем файлы из папки в архив
Dim sTmpF$
sTmpF = Environ("temp") & "\" & Format(now,"DD_MM_YYYY_hh-mm-ss")
objShell.Namespace((sTmpF)).Movehere .Namespace(sFileToZIP).Items, &H4&
objShell.NameSpace((sZIPFileName)).CopyHere CStr(sTmpF), &H4&
'дожидаемся окончания архивации
Do Until objShell.NameSpace((sZIPFileName)).Items.Count = lcnt + 1
DoEvents
Loop
RmDir sTmpF
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Понял в чём проблема. &H4 не показывает прогресс копирования файлов в архив, но не отменяет диалога процента сжатия, увы. Приношу свои извинения за поспешность в рекомендациях.
Дмитрий(The_Prist) Щербаков, действительно как-то глупо с моей стороны, извините((( Теперь ошибок не выдает, сохраняет в temp, но не архивирует
Код
'Скопировать весь текст в Outlook в модуль VBA
'C:\Users\USERNAME\Documents\MyEmails
Private WithEvents OutboxItems As Outlook.Items
Private WithEvents InboxItems As Outlook.Items
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
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 = Environ("temp")
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, "")
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
m = Replace(s, xFilePath & "\", "")
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
'xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
Call ZIPOneFile(xFilePath & "\MyEmails.zip", s)
'Kill s
End If
For j = 1 To xMailItem.Attachments.Count
x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
For n = 1 To 9
x = Replace(x, "image00" & n & ".png;", "")
x = Replace(x, "image00" & n & ".jpg;", "")
x = Replace(x, "image00" & n & ".jpeg;", "")
x = Replace(x, "image00" & n & ".gif;", "")
Next
For n = 10 To 99
x = Replace(x, "image0" & n & ".png;", "")
x = Replace(x, "image0" & n & ".jpg;", "")
x = Replace(x, "image0" & n & ".jpeg;", "")
x = Replace(x, "image0" & n & ".gif;", "")
Next
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")
Dim k As String
Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
k = m & 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
Dim s As String
On Error Resume Next
xFilePath = Environ("temp")
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, "")
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
m = Replace(s, xFilePath & "\", "")
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
'xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
Call ZIPOneFile(xFilePath & "\MyEmails.zip", s)
'Kill s
End If
For j = 1 To xMailItem.Attachments.Count
x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
For n = 1 To 9
x = Replace(x, "image00" & n & ".png;", "")
x = Replace(x, "image00" & n & ".jpg;", "")
x = Replace(x, "image00" & n & ".jpeg;", "")
x = Replace(x, "image00" & n & ".gif;", "")
Next
For n = 10 To 99
x = Replace(x, "image0" & n & ".png;", "")
x = Replace(x, "image0" & n & ".jpg;", "")
x = Replace(x, "image0" & n & ".jpeg;", "")
x = Replace(x, "image0" & n & ".gif;", "")
Next
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")
Dim k As String
Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
k = m & 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
Function ZIPOneFile(sZIPFileName As String, sFileToZIP As String)
Dim objShell As Object
Dim lcnt As Long
Set objShell = CreateObject("Shell.Application")
'создаем пустой ZIP-архив, если его еще нет
If Dir(sZIPFileName, 16) = "" Then
CreateNewZip (sZIPFileName)
End If
lcnt = objShell.NameSpace((sZIPFileName)).Items.Count
'помещаем файлы из папки в архив
Dim sTmpF$
sTmpF = Environ("temp") & "\" & Format(Now, "DD_MM_YYYY_hh-mm-ss")
objShell.NameSpace((sTmpF)).Movehere objShell.NameSpace(sFileToZIP).Items, &H4&
objShell.NameSpace((sZIPFileName)).CopyHere CStr(sTmpF), &H4&
'дожидаемся окончания архивации
Do Until objShell.NameSpace((sZIPFileName)).Items.Count = lcnt + 1
DoEvents
Loop
RmDir sTmpF
End Function
Sub CreateNewZip(sPath As String)
If Dir(sPath) <> "" Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Dim sTmpF$
Dim sFileToZIP, sZIPFolderName, sF$
Dim objShell
Set objShell = CreateObject("Shell.Application")
sFileToZIP = "C:\123.xlsx"
sZIPFolderName = "C:\Users\User\Desktop\"
sTmpF = Environ("temp") & "\" & Format(Now, "DD_MM_YYYY_hh-mm-ss")
If Dir(sTmpF, 16) = "" Then
MkDir sTmpF
End If
sF = sTmpF & "\123.zip"
'создаем пустой ZIP-архив, если его еще нет
If Dir(sF, 16) = "" Then
CreateNewZip (sF)
End If
objShell.Namespace((sF)).CopyHere CStr(sFileToZIP), &H4&
objShell.Namespace((sZIPFolderName)).Movehere objShell.Namespace((sF)), &H4&
RmDir sTmpF
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
'Скопировать весь текст в Outlook в модуль VBA
'C:\Users\USERNAME\Documents\MyEmails
Private WithEvents OutboxItems As Outlook.Items
Private WithEvents InboxItems As Outlook.Items
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
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 = Environ("temp")
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, "")
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
m = Replace(s, xFilePath & "\", "")
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
'Call ZIPOneFile(xFilePath & "\MyEmails.zip", s)
Dim sTmpF$
Dim sFileToZIP, sZIPFolderName, sF$
Dim objShell
Set objShell = CreateObject("Shell.Application")
sFileToZIP = s
sZIPFolderName = "C:\Users\User\Desktop\"
sTmpF = Environ("temp") & "\" & Format(Now, "DD_MM_YYYY_hh-mm-ss")
If Dir(sTmpF, 16) = "" Then
MkDir sTmpF
End If
sF = xFilePath & "\MyEmails.zip"
'создаем пустой ZIP-архив, если его еще нет
If Dir(sF, 16) = "" Then
CreateNewZip (sF)
End If
objShell.NameSpace((sF)).CopyHere CStr(sFileToZIP), &H4&
objShell.NameSpace((sZIPFolderName)).Movehere objShell.NameSpace((sF)), &H4&
RmDir sTmpF
End If
For j = 1 To xMailItem.Attachments.Count
x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
For n = 1 To 9
x = Replace(x, "image00" & n & ".png;", "")
x = Replace(x, "image00" & n & ".jpg;", "")
x = Replace(x, "image00" & n & ".jpeg;", "")
x = Replace(x, "image00" & n & ".gif;", "")
Next
For n = 10 To 99
x = Replace(x, "image0" & n & ".png;", "")
x = Replace(x, "image0" & n & ".jpg;", "")
x = Replace(x, "image0" & n & ".jpeg;", "")
x = Replace(x, "image0" & n & ".gif;", "")
Next
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")
Dim k As String
Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
k = m & 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
Dim s As String
On Error Resume Next
xFilePath = Environ("temp")
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, "")
s = GetAtchName(xFilePath & "\" & xFileName & ".msg")
m = Replace(s, xFilePath & "\", "")
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
xMailItem.SaveAs s, olMsg 'xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
'Call ZIPOneFile(xFilePath & "\MyEmails.zip", s)
Dim sTmpF$
Dim sFileToZIP, sZIPFolderName, sF$
Dim objShell
Set objShell = CreateObject("Shell.Application")
sFileToZIP = s
sZIPFolderName = "C:\Users\User\Desktop\"
sTmpF = Environ("temp") & "\" & Format(Now, "DD_MM_YYYY_hh-mm-ss")
If Dir(sTmpF, 16) = "" Then
MkDir sTmpF
End If
sF = xFilePath & "\MyEmails.zip"
'создаем пустой ZIP-архив, если его еще нет
If Dir(sF, 16) = "" Then
CreateNewZip (sF)
End If
objShell.NameSpace((sF)).CopyHere CStr(sFileToZIP), &H4&
objShell.NameSpace((sZIPFolderName)).Movehere objShell.NameSpace((sF)), &H4&
RmDir sTmpF
End If
For j = 1 To xMailItem.Attachments.Count
x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j
For n = 1 To 9
x = Replace(x, "image00" & n & ".png;", "")
x = Replace(x, "image00" & n & ".jpg;", "")
x = Replace(x, "image00" & n & ".jpeg;", "")
x = Replace(x, "image00" & n & ".gif;", "")
Next
For n = 10 To 99
x = Replace(x, "image0" & n & ".png;", "")
x = Replace(x, "image0" & n & ".jpg;", "")
x = Replace(x, "image0" & n & ".jpeg;", "")
x = Replace(x, "image0" & n & ".gif;", "")
Next
x = Replace(x, " ", "")
x = Replace(x, ";", "; ")
Dim k As String
Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
k = m & 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
Function ZIPOneFile(sZIPFileName As String, sFileToZIP As String)
Dim objShell As Object
Dim lcnt As Long
Set objShell = CreateObject("Shell.Application")
'создаем пустой ZIP-архив, если его еще нет
If Dir(sZIPFileName, 16) = "" Then
CreateNewZip (sZIPFileName)
End If
lcnt = objShell.NameSpace((sZIPFileName)).Items.Count
'помещаем файлы из папки в архив
objShell.NameSpace((sZIPFileName)).CopyHere CStr(sFileToZIP)
'дожидаемся окончания архивации
Do Until objShell.NameSpace((sZIPFileName)).Items.Count = lcnt + 1
DoEvents
Loop
End Function
Sub CreateNewZip(sPath As String)
If Dir(sPath) <> "" Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub