Найти папки по частичному имени - PullRequest
Новая
       22

Найти папки по частичному имени

1 голос
/ 06 мая 2019

У меня есть рабочие листы для генерации электронных писем (в Outlook) с учетом параметров, вставленных пользователем.

У меня есть код, работающий для записи и включающий таблицы в тело письма.

Мне нужно включить вложения в формате PDF.

Файлы находятся в каталоге, имя которого всегда будет:
- число (на листе)
- случайная строка

Пример: человек запрашивает электронную почту с номером 340,
Мне нужно найти папку 340-srts.

Там будет только одна папка, начиная с "340"

IsЕсть ли способ найти папку и получить файлы внутри нее, имея только часть ее имени? 

Dim OutMail As Object

Set OutMail = OutApp.CreateItem(0)

rma_number = Worksheets("HEADER").Range("C5").Value2


With OutMail
.To = To_Mail
.CC = ""
.BCC = ""
.Subject = "some text"
.HTMLBody = "more text"
.attachments.Add Dir("\\Pmbrsor-fs01\Compartilhado\CSR\Arquivos de Chamados\Chamados Internos\" + Cstr(rma_number)*)
.Display
End With


'also tried

Get_Laudo = Dir("\\Pmbrsor-fs01\Compartilhado\CSR\Arquivos de Chamados\Chamados Internos\" + Cstr(rma_number)*)

1 Ответ

2 голосов
/ 06 мая 2019

Вы не можете добавить файл напрямую, используя подстановочный знак в пути: сначала вы должны увидеть, существует ли файл с помощью Dir (), а затем добавить вложение с фактическим именем файла.

Для одного файла это выглядело бы так: 

Const FLDR_PATH As String = "\\Pmbrsor-fs01\Compartilhado\CSR\Arquivos de Chamados\Chamados Internos\"

Dim fName

fName = Dir(FLDR_PATH  & Cstr(rma_number) & "*")

If fName  <> "" Then 
    .attachments.Add FLDR_PATH & fName
Else
    MsgBox "Attachment file not found!"
End If

РЕДАКТИРОВАТЬ: после более внимательного изучения вопроса и понимания того, что вы искали папку с использованием подстановочного знака, а затем хотели, чтобы все файлы находились вэта папка. 

Sub Tester()

    Dim attach As Collection, f

    Set attach = MatchingFiles(rma_number)
    If attach.Count > 0 Then
        For Each f In attach
            .attachments.Add f
        Next f
    Else
        MsgBox "No matching attachments found!"
    End If

End Sub

'return all file in folder matching the provided rma number
Function MatchingFiles(rma_number)
    Const FLDR_PATH As String = "\\Pmbrsor-fs01\Compartilhado\CSR\Arquivos de Chamados\Chamados Internos\"
    Dim rv As New Collection
    Dim fldr, fName

    'First see if we can find the folder
    fldr = Dir(FLDR_PATH & CStr(rma_number) & "-*", vbDirectory)
    If Len(fldr) > 0 Then
        'Found the folder, so collect all of the contained files
        fName = Dir(FLDR_PATH & fldr & "\*", vbNormal)
        Do While Len(fName) > 0
            rv.Add FLDR_PATH & fldr & "\" & fName '<< add the full path for this file
            fName = Dir() '<< next file
        Loop
    End If
    Set MatchingFiles = rv
End Function
...