Прикрепления файлов

@olga8774 · Регистрация: 26.03.2016

Author24 — интернет-сервис помощи студентам

Нужно создать базу с полями
- дата в формате ГГГГ-ММ-ДД (не знаю как сделать маску ввода)
- номер отдела
- фамилия
- краткая информация
- прикрепить файл служебной записки в формате pdf
с 4 колонками проблем не возникло, была создана форма которая вводит данные ( но пока не реализована маска для вводы даты)
Возникли проблемы с написание кода для добавления ссылки на файл, было найдено вот такое решение

Visual Basic

Sub ShowFileDialog()
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы отчетов" 'заголовок окна диалога
        .ButtonName = "Выбрать файлы Excel или текстовые файлы"
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .Filters.Add "pdf", "*.pdf", 3 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 3 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = "C:\Temp\Книга1.xlsx" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Sub 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            'Workbooks.Open x 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
            Cells(lf + 8, 1).Value = .SelectedItems(lf)
        Next
    End With
    MsgBox "Пути с именами файлов записаны, начиная с ячейки A9", vbInformation, "www.excel-vba.ru"
End Sub

оно очень изящно, но оно немного не соответствует, не могу сделать что бы к каждой записи была возможность прикрепить файл, если файл не прикрепен, то не давало возможности добавить эту запись.
После того как будет получена ссылка на файл в ячейку при каждой записи, нужно сформировать имя нового файла из колонок в таком виде дата+номер отдлеа+фамилия+ краткое описание и скопировать файл по ссылке в определнную папку с новым именем. Буду очень рада любой информации, которая подтолкнет к решению, пролистывала весь интренет не нашло похожего...
Так же прикреплю файл с моей формой (она немного не моя, но была переделана под то что мне нужно)
Возможно решение будет другим. Но суть моей проблемы в том, что нужно сканировать документы и присваивать им нужные имена и помещать в папку, видела тут темы как переименовывать файлы, но не подходит потому что когда фал открыт его не нельзя переименовать. Как то так...

@olga8774 · 26.03.2016, 22:22 **[ТС]**

Visual Basic

Sub Copy_File()
    Dim objFSO As Object, objFile As Object
    Dim sFileName As String, sNewFileName As String
    sPathNew$ = [b3]
    sFileName = [f2] 'ссылка на отсканированный документ
    sNewFileName = sPathNew & [e2] & ".xls"   'новое имя + новый путь
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "ошибка": Exit Sub
    
    '???????? ????
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.GetFile(sFileName)
    objFile.Copy sNewFileName
 
    MsgBox "Все ок", vbInformation, "www.excel-vba.ru"
End Sub

Вот так копирую и называю по новой файл

Добавлено через 6 минут
не могу только одно сделать

Visual Basic

1	Cells(lf + 8, 1).Value = .SelectedItems(lf)

вот это записывает путь до файла в ячейку, а мне еще нужно записывать путь ну или хотя бы имя файла в TextBox1

Visual Basic

1	пишу еще TextBox1).Value = .SelectedItems(lf)

но это не работает, помогите пожалуйста и все будет решено
дальше я просто каждый раз буду очищать список и вновь переименовывать и копировать

Visual Basic

1
2
3

Sub ОчисткаСписка()
   Worksheets("Лист1").Range("A2:E2" & Range("A65536").End(xlUp).Row).ClearContents
End Sub

вот такая логика

@olga8774 · 27.03.2016, 11:04 **[ТС]**

Visual Basic

Sub ShowFileDialog11()
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы отчетов" 'заголовок окна диалога
        .ButtonName = "Выбрать файлы Excel или текстовые файлы"
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 2 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = "C:\Temp\Книга1.xlsx" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Sub 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            'Workbooks.Open x 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
            Cells(lf + 1, 6).Value = .SelectedItems(lf)
           
        Next
    End With
    MsgBox "Все прошло нормально", vbInformation, "www.excel-vba.ru"
End Sub
Sub Copy_File()
    Dim objFSO As Object, objFile As Object
    Dim sFileName As String, sNewFileName As String
    sPathNew$ = [H1]
    sFileName = [f2] 'ссылка на отсканированный документ
    sName = [a2] & ". " & [b2] & ". " & [c2] & ". " & [d2]
    sNewFileName = sPathNew & sName & ".xls"  'новое имя + новый путь
    ActiveSheet.Hyperlinks.Add Range("a" & Rows.Count).End(xlUp), sNewFileName, "", _
                                   "Просмотреть файл" & vbNewLine
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "ошибка": Exit Sub
    Cells(2, 5).Value = sNewFileName
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.GetFile(sFileName)
    objFile.Copy sNewFileName
 
    MsgBox "Все ок", vbInformation, "www.excel-vba.ru"
End Sub
Sub mCopyData()
Dim mRng As Range
    Set mRng = Worksheets("Лист1").Range("A2:D2")
    If Application.CountA(mRng) = 0 Then
        MsgBox "Empty!!!"
        Exit Sub
            Else
                mRng.Copy Sheets("Лист2"). _
                        Cells(Rows.Count, 1) _
                                .End(xlUp).Offset(1, 0)
    End If
End Sub
Sub ОчисткаСписка()
   Worksheets("Лист1").Range("A2:F2" & Range("A65536").End(xlUp).Row).ClearContents
End Sub

Вот что вышло поправьте, если будут у ког мысли как сделать лучше
но алгоритм такой добавляем файл, вносим данные, делаем новое имя, копируем в другую директорию с новым именем, записываем на новый лист с гиперсылкой и стираем данные из ячеек! Как то так....

	27.03.2016, 11:04