Копирование файла на сетевой диск

[Amrek]

Подскажите пожалуйста,

А возможно ли сделать такое:

Как сейчас: Когда пользователь нажимает Гиперссылка и указывает файл, на своем компе то ссылка приобритает вид C:\Documents and Settings\user\Рабочий стол\файл И если теперь попробовать открыть эксель с другого компа и попробовать открыть эту ссылку ничего не получится. Имеется ввиду абсолютно любой файл, rar, xls, txt и т.д.

Что бы хотелось, при нажатии на кнопку добавить файл открывалось окно выбора файла, выбираем абсолютно любой файл, в любом месте. Жмем ок. Далее файл копируется на сетевой диск, а в экселе появляется ссылка на этот файл на сетевом диске.

Такое вообще возможно средставми Екселя? И если да то не подскажите код?

[Hugo121]

Option Explicit

Sub tt()
Dim ИмяФайла$

'1.при нажатии на кнопку добавить файл открывалось окно выбора файла, выбираем абсолютно любой файл, в любом месте. Жмем ок.
ИмяФайла = GetFileName("Заголовок окна", ThisWorkbook.Path) ' запрашиваем имя файла
' ===================== другие варианты вызова функции =====================
' текстовые файлы, стартовая папка не указана
' ИмяФайла = GetFileName("Выберите текстовый файл", , "Текстовые файлы (*.txt),")
' файлы любого типа из папки "C:\Windows"
' ИмяФайла = GetFileName(, "C:\Windows", "")
' ==========================================================================

If ИмяФайла = "" Then Exit Sub ' выход, если пользователь отказался от выбора файла

'2.Далее файл копируется на сетевой диск, 
Dim КороткоеИмяФайла$
КороткоеИмяФайла = Split(ИмяФайла, "\")(UBound(Split(ИмяФайла, "\")))
FileCopy ИмяФайла, "\\I6424\Temp\" & КороткоеИмяФайла

'3.а в экселе появляется ссылка на этот файл на сетевом диске.
ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="\\I6424\Temp\" & КороткоеИмяФайла

End Sub


Function GetFileName(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath, _
Optional ByVal MyFilter As String = "Книги Excel (*.xls*),") As String
' функция выводит диалоговое окно выбора папки с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
If Not IsMissing(InitialPath) Then
On Error Resume Next: ChDrive Left(InitialPath, 1)
ChDir InitialPath ' выбираем стартовую папку
End If
Dim res$
res = Application.GetOpenFilename(MyFilter, , Title, "Открыть") ' вывод диалогового окна
GetFileName = IIf(VarType(res) = vbBoolean, "", res) ' пустая строка при отказе от выбора
End Function

Хотя при тестировании всплыли недоработки - нужно чуть изменить отказ от выбора файла:

If ИмяФайла = "False" Then Exit Sub ' выход, если пользователь отказался от выбора файла

и MyFilter скорректировать:

Optional ByVal MyFilter As String = "Все файлы (*.*),") As String