Здравствуйте! Необходим макрос, который бы собирал ПОСЛЕДНИЕ файлы определенного формата из указанной папки, потом всё архивировалось и отправлялось пользователю в otlook. НО есть один момент. Письмо должно не сразу отправляться, а создаваться черновиков с конкретным пользователем. Пока получилось так:
I10 - это ячейка с адресом папки. Жирным выделила то, где не получается, выходит ошибка
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
Sub Zip_File_Or_Files()
Dim sDate As String, sZIPPath As String, sZIPFileName As String, sWBName As String
Dim objShell As Object, lf As Long, lZIPCnt As Long
Dim LastFile$
If VarType(LastFile$) = vbBoolean Then Exit Sub
sZIPPath = Replace(LastFile$(1), Dir(LastFile$(1), 16), "") If Right(sZIPPath, 1) <> "\" Then
sZIPPath = sZIPPath & "\"
End If
sDate = Format(Now, " dd-mm-yy h-mm-ss")
sZIPFileName = sZIPPath & "Логи" & sDate & ".zip"
CreateNewZip (sZIPFileName)
Set objShell = CreateObject("Shell.Application")
lZIPCnt = 0
For lf = LBound(avFiles) To UBound(avFiles)
sWBName = Dir(avFiles(lf), 16)
If IsBookOpen(sWBName) Then
MsgBox "Невозможно поместить файл'" & avFiles(lf) & "' в архив!" & vbNewLine & _
"Закройте книгу и повторите попытку."
Else
lZIPCnt = lZIPCnt + 1
objShell.Namespace((sZIPFileName)).CopyHere CStr(avFiles(lf))
Do Until objShell.Namespace((sZIPFileName)).Items.Count = lZIPCnt
DoEvents
Loop
End If
Next lf
If lZIPCnt Then
MsgBox "Архив создан по пути: " & sZIPFileName
End If
Send_Mail sZIPFileName
End Sub
Function IsBookOpen(wbName As String) As Boolean
Dim wbBook As Workbook: On Error Resume Next
Set wbBook = Workbooks(wbName)
IsBookOpen = Not wbBook Is Nothing
End Function
Sub Send_Mail(sPath As String)
Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
Application.ScreenUpdating = False
On Error Resume Next
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If
Set objMail = objOutlookApp.CreateItem(0)
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
sTo = Range("B32").Value
sSubject = Range("F3").Value
sBody = Range("F8").Value
sAttachment = sPath
With objMail
.To = sTo
.CC = ""
.BCC = ""
.Subject = sSubject
.Body = sBody
If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment
End If
End If
.Send
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub
Function LastFile$(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
Optional ByVal SearchDeep As Long = 999)
Dim FilenamesCollection As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
GetAllfileNameUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep
Set FSO = Nothing: Application.StatusBar = False
Dim maxFileDate As Double
For Each file In FilenamesCollection
currFileDate = FileDateTime(file)
If currFileDate > maxFileDate Then LastFile$ = file: maxFileDate = currFileDate
Next file
End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
If Not curfold Is Nothing Then
Application.StatusBar = "Поиск в папке: " & FolderPath
For Each fil In curfold.Files
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
Next
SearchDeep = SearchDeep - 1
If SearchDeep Then
For Each sfol In curfold.subfolders
GetAllfileNameUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
Next
End If
Set fil = Nothing: Set curfold = Nothing
End If
End Function
