Страницы: 1
RSS
Скрыть процесс архивации/разорхивации windows
 
Добрый день!  :)
Благодаря The_Prist(Щербакову Дмитрию) я нашел в интернете код, который архивирует файлы с помощью встроенного в windows архиватора.  ;)
Но при использовании данного кода отображается процесс архивации, который жутко напрягает.  :evil:
Подскажите пожалуйста, как скрыть данное окно?

Код
'---------------------------------------------------------------------------------------
' 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 - 12.04.2021 06:19:14
 
Доброе время суток
Цитата
evgeniygeo написал:
как скрыть данное окно?
Всё как всегда - изучить аргументы метода Folder.CopyHere. Там не так много букв :)
 
Андрей VG,
что-то у меня совсем не получается.  :sceptic:
То ли я дурак, то ли лыжи не едут  :cry:
Исправляюсь  :)

Код
objShell.Namespace((sZIPFileName)).CopyHere(sFileToZIP, 4)
Изменено: evgeniygeo - 12.04.2021 07:09:20
 
evgeniygeo, не перебарщивайте с самокритикой, ни к чему это. Исходя из
Цитата
Return value
This method does not return a value.
, можно сделать вывод, что CopyHere - это процедура. Следовательно скобки при её вызове не нужны. Одна из дурацких особенностей VBA. Причём да, если аргумент в процедуру передаётся один, то это как бы претензий у компилятора не вызывает :)   Учитывая то, что вы не часто кодите, то о такой особенности - можете и не знать. А вот о чём вам выдаётся сообщение - лучше всегда приводить полностью - это единственное за что вас можно пожурить.
Код
objShell.Namespace((sZIPFileName)).CopyHere sFileToZIP, 4
Изменено: Андрей VG - 12.04.2021 07:05:38
 
Андрей VG,
к сожалению, процесс сжатия все равно отображается  :sceptic:

вот полный код, возможно пригодится:
Код
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
Изменено: evgeniygeo - 12.04.2021 07:13:39
 
Попробуйте сначала перемещать файлы во временную папку, а из неё уже создавать архив. Помню была подобная проблема при извлечении. Не знаю, поможет ли при архивации. Что-то вроде:
Код
    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) Щербаков,
к сожалению, выдает ошибку
 
 
Ну вот это вообще не ошибка :) Надо просто было додумать чутка - перед точкой объект поставить(я писал на коленке, поэтому и ошибка):
Код
objShell.Namespace((sTmpF)).Movehere objShell.Namespace(sFileToZIP).Items, &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


Изменено: evgeniygeo - 12.04.2021 14:00:33
 
Вроде так:
Код
    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
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков,
все работает, архивируется, но при этом процесс архивации отображается  :(
Код
'Скопировать весь текст в 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



 
Цитата
evgeniygeo написал:
при этом процесс архивации отображается
значит здесь такой финт не прокатывает. Других идей нет.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков,
спасибо Вам за уделенное время  :)  
Страницы: 1
Наверх