Архивирование и отправка файлов

[vika_pravda]

Добрый день! В продолжении темы https://www.excel-vba.ru/forum/index.php?topic=6713.0.
Требуется небольшая доработка, подскажите, пожалуйста:

1. Требуется заменить "выбор папки" на конкретную, но имя папки состоит из нескольких аргументов, например, "C:\User\***\App\Roaming\&&&, где
- *** - это имя пользователя Excel;
- &&& - выбор папки, их будет три и более (например, САМАРА, ТВЕРЬ, ПСКОВ).

Я пробовала несколькими способами. Сначала просто ввести формулу =сцепить("C:\User\";username();"App\Roaming\";"B2"), где В2 - папка через проверку данных, НО оказывается сама функция username() не работает.

Нашла код VBA, но его надо вставлять в макрос:

Код: (vb)

Public Function ИМЯПОЛЬЗОВАТЕЛЯ() As String
    ИМЯПОЛЬЗОВАТЕЛЯ = Environ("UserName")
End Function

2. Из выбранной папки необходимо забирать только последние файлы (например, "doc"). Вот тут я не нашла даже похожего макроса. По логике можно идти двумя вариантами:
- как-то в условии сбора указать "последнее обновление, добавление";
- ввести в наименовании файлов числа фиксирующие недели (например "Билайн_15"/"Билайн_16").

Полагаю, что изменения необходимо вставлять в эту часть:

Код: (vb)

Dim avFiles  
    avFiles = Application.GetOpenFilename("TEXT Files (*.txt*),*.txt*", , "Выбрать файлы для архивации", , True)  
    If VarType(avFiles) = vbBoolean Then Exit Sub  
    sZIPPath = Replace(avFiles(1), Dir(avFiles(1), 16), "")  
    If Right(sZIPPath, 1) <> "\" Then  
        sZIPPath = sZIPPath & "\"  
    End If  

Можете мне помочь?

[vika_pravda]

Код: (vb)

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 avFiles  
    avFiles = Application.GetOpenFilename("TEXT Files (*.txt*),*.txt*", , "Выбрать файлы для архивации", , True)  
    If VarType(avFiles) = vbBoolean Then Exit Sub
    sZIPPath = "A1" & userprofile & "В1" & "С1" (или sZIPPath = "C:\User\" & userprofile & "\App\Roaming\" & "C1")

Где:
А1 = C:\User\
B1 = \App\Roaming\
C1 =выбор данных


Имя пользователя:

Код: (vb)

Sub userprofile()
   Dim myPath As String
   myPath = Environ$("userprofile")
   MsgBox myPath
End Sub

https://excelvba.ru/code/UserFullName

[vika_pravda]

или лучше использовать промежуточную формулу сцепления?

https://www.cyberforum.ru/vba/thread2435816.html

По второму вопросу, последний добавленный файл в папку, нашла такой макрос: https://excelvba.ru/code/LastFile

Код: (vb)

Sub LastFile()
      Dim sZIPPath$, LastFile$
      sZIPPath = 'пример выше'
      LastFile$= LastFile$(sZIPPath, ".txt", 3)
      If LastFile$ = "" Then MsgBox "Не найдено ни одного файла", vbExclamation: Exit Sub
    MsgBox LastFile$, vbInformation, "Самый свежий файл"
End Sub

НО я не понимаю, что значит "3"?

[vika_pravda]

По дополнительному требованию = "отправить скриншот при необходимости"

Нашла ваши рекомендации тут: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=122730&TITLE_SEO=122730-otpravka-snimka-diapazona-excel-cherez-outlook

НО тут вы рассматриваете вариант скриншота из excel, а нужны скриншоты с рабочей области, т.е. открыто может быть, что угодно.

Можно что-то тут придумать?

[Дмитрий Щербаков(The_Prist)]

Виктория, проблема в том, что по сути, для помощи Вам есть только два рабочих варианта:
Вариант 1: надо взять и написать нужные коды с нуля. Но это уже мало похоже на помощь и в таком случае надо терпеливо ждать того, кому будет интересно сделать это по собственным соображениям.
Вариант 2: попытаться научить Вас азам VBA, т.к. по Вашим попыткам отчетливо видно, что без этого обучения пояснить Вам что и как куда дольше и сложнее, чем написать все для Вас с нуля.

Да и все Ваши вопросы хоть и связаны одной задачей(Вашей), разные по сути. А не связанные между собой вопросы задаются в разных темах. п.п. 4.16. Правил форума

[vika_pravda]

То что у меня получилось. Где выходит ошибка отметила жирным.
Единственный вопрос: функция последний файл в данной сборке будет выводить последний файл, а если их будет несколько? Он будет проверять по дате? Просто нужны все последние по дате.

I10 - адрес папки.
Вопрос с составлением адреса решила сама.

Код: (vb)

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