Как известно при совместном общем доступе нельзя вставлять гиперссылку через меню. Можно через функцию Гиперссылка. Но при этом приходится делать много манипуляций (собственно прописать функцию, скопировать и вставить путь к файлу, прописать имя ссылки). Есть код который немного упрощает данное действие. Он обрабатывает событие Двойной щелчок и запускает файл путь которого достаточно скопировать в ячейку.
Цитата Manyasha, 28.01.2016 в 11:43, в сообщении № 9 [vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Columns(5)) Is Nothing Then If Target.Value <> "" Then fPath = "start " & """"" " & """" & Target.Value & """""" Shell "cmd /c" & fPath, vbHide: Cancel = True End If End If End Sub
[/vba]
Хотелось бы узнать можно ли усовершенстовать данный код чтобы в ячейке отображалось только имя файла без полного пути. Но при этом по двойному щелчку открывался бы сам файл.
Как известно при совместном общем доступе нельзя вставлять гиперссылку через меню. Можно через функцию Гиперссылка. Но при этом приходится делать много манипуляций (собственно прописать функцию, скопировать и вставить путь к файлу, прописать имя ссылки). Есть код который немного упрощает данное действие. Он обрабатывает событие Двойной щелчок и запускает файл путь которого достаточно скопировать в ячейку.
Цитата Manyasha, 28.01.2016 в 11:43, в сообщении № 9 [vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Columns(5)) Is Nothing Then If Target.Value <> "" Then fPath = "start " & """"" " & """" & Target.Value & """""" Shell "cmd /c" & fPath, vbHide: Cancel = True End If End If End Sub
[/vba]
Хотелось бы узнать можно ли усовершенстовать данный код чтобы в ячейке отображалось только имя файла без полного пути. Но при этом по двойному щелчку открывался бы сам файл.fairylive
Сообщение отредактировал fairylive - Пятница, 29.01.2016, 18:08
Формулы не очень хороши тем что кому-то надо их периодически продливать вниз (90% это делать умеют, но есть и такие кто с компьютером на Вы, собственно для них все эти формулы и функции полная дичь и именно эти люди тратят кучу времени на заполнение этой таблицы и именно они чаще других конфликтуют с другими). И скрытый столбец тоже не вариант так как туда же мы хотели вставлять имя файла. Хотя тут можно один раз сделать группировку и открывать\закрывать его. Цель - открыть файл, быстро внести изменения и выйти, чтобы не мешать другим.
В идеале как я это вижу: Мы скопировали путь к файлу в буфер обмена. Затем выделяем ячейку и по событию или сочетанию клавиш, с помощью макроса или кода VBA в данной ячейке появляется имя файла, при этом двойной щёлчок по имени должен открывать сам файл. Если заполнять выделенную ячейку тем же событием Двойной щелчок то надо чтобы была какая-то проверка - пока пусто заполняется ячейка (данные берутся из буфера обмена и там должен быть только путь), если в ячейке уже что-то есть то по двойному щелчку пытаться это что-то открыть.
Формулы не очень хороши тем что кому-то надо их периодически продливать вниз (90% это делать умеют, но есть и такие кто с компьютером на Вы, собственно для них все эти формулы и функции полная дичь и именно эти люди тратят кучу времени на заполнение этой таблицы и именно они чаще других конфликтуют с другими). И скрытый столбец тоже не вариант так как туда же мы хотели вставлять имя файла. Хотя тут можно один раз сделать группировку и открывать\закрывать его. Цель - открыть файл, быстро внести изменения и выйти, чтобы не мешать другим.
В идеале как я это вижу: Мы скопировали путь к файлу в буфер обмена. Затем выделяем ячейку и по событию или сочетанию клавиш, с помощью макроса или кода VBA в данной ячейке появляется имя файла, при этом двойной щёлчок по имени должен открывать сам файл. Если заполнять выделенную ячейку тем же событием Двойной щелчок то надо чтобы была какая-то проверка - пока пусто заполняется ячейка (данные берутся из буфера обмена и там должен быть только путь), если в ячейке уже что-то есть то по двойному щелчку пытаться это что-то открыть.fairylive
Макрос работает так. Если в ячейке пусто, то появится диалоговое окно, в которое нужно вставить путь и имя файла. После этого в ячейке появится формула с функцией Гиперссылка. Если же в ячейке уже будут данные, то при двойном щелчке произойдет открытие файла (т.к. произойдет щелчок по гиперссылке). [vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strPath As String, lngInstr As Long
Cancel = True If Target.Value <> "" Then Exit Sub strPath = InputBox("Вставьте путь файла:") If strPath = "" Then Exit Sub lngInstr = InStrRev(strPath, "\") Target.Value = "=HYPERLINK(" & """" & strPath & """" & "," & """" & Mid(strPath, lngInstr + 1) & """" & ")"
End Sub
[/vba]
Макрос работает так. Если в ячейке пусто, то появится диалоговое окно, в которое нужно вставить путь и имя файла. После этого в ячейке появится формула с функцией Гиперссылка. Если же в ячейке уже будут данные, то при двойном щелчке произойдет открытие файла (т.к. произойдет щелчок по гиперссылке). [vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strPath As String, lngInstr As Long
Cancel = True If Target.Value <> "" Then Exit Sub strPath = InputBox("Вставьте путь файла:") If strPath = "" Then Exit Sub lngInstr = InStrRev(strPath, "\") Target.Value = "=HYPERLINK(" & """" & strPath & """" & "," & """" & Mid(strPath, lngInstr + 1) & """" & ")"
Karataev, что-то не работает как надо. Ошибка выскакивает. Хотя я тут разобрался. Дело в том что когда в то окошко копируется путь он уже заключен в кавычки. Если их убрать то всё работает. Напомню что если щёлкнуть по файлу правой клавишей мыши с зажатым SHIFT то в контекстном меню появляется строчка Копировать как путь. При этом в буфер обмена помещается путь в кавычках. Например "C:\Users\Вова\Documents\титры в edl.xlsx". Так что код надо поправить. Я правда пока не понимаю как. Слишком много двойных кавычек для меня.
Karataev, что-то не работает как надо. Ошибка выскакивает. Хотя я тут разобрался. Дело в том что когда в то окошко копируется путь он уже заключен в кавычки. Если их убрать то всё работает. Напомню что если щёлкнуть по файлу правой клавишей мыши с зажатым SHIFT то в контекстном меню появляется строчка Копировать как путь. При этом в буфер обмена помещается путь в кавычках. Например "C:\Users\Вова\Documents\титры в edl.xlsx". Так что код надо поправить. Я правда пока не понимаю как. Слишком много двойных кавычек для меня.fairylive
Вот немного доделал чтобы данный макрос работал только с пятым столбцом. Вроде работает. Я в этом ничего не понимаю пока. Просто добавил две строчки из кода в первом сообщении.
[vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Columns(5)) Is Nothing Then Dim strPath As String, lngInstr As Long
Cancel = True If Target.Value <> "" Then Exit Sub strPath = InputBox("Вставьте путь файла:") If strPath = "" Then Exit Sub strPath = Mid(strPath, 2, Len(strPath) - 2) lngInstr = InStrRev(strPath, "\") Target.Value = "=HYPERLINK(" & """" & strPath & """" & "," & """" & Mid(strPath, lngInstr + 1) & """" & ")" End If End Sub
[/vba]
Вот немного доделал чтобы данный макрос работал только с пятым столбцом. Вроде работает. Я в этом ничего не понимаю пока. Просто добавил две строчки из кода в первом сообщении.
[vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Columns(5)) Is Nothing Then Dim strPath As String, lngInstr As Long
Cancel = True If Target.Value <> "" Then Exit Sub strPath = InputBox("Вставьте путь файла:") If strPath = "" Then Exit Sub strPath = Mid(strPath, 2, Len(strPath) - 2) lngInstr = InStrRev(strPath, "\") Target.Value = "=HYPERLINK(" & """" & strPath & """" & "," & """" & Mid(strPath, lngInstr + 1) & """" & ")" End If End Sub
Помогите доработать макрос. На некоторых компах при вставке в появляющееся окно Пути файла вставляются знаки вопроса вместо русских букв. Надо что-то с кодировкой сделать. Пока не могу найти что именно.
Помогите доработать макрос. На некоторых компах при вставке в появляющееся окно Пути файла вставляются знаки вопроса вместо русских букв. Надо что-то с кодировкой сделать. Пока не могу найти что именно.fairylive
"Допилить" можно. Нужно в коде макроса сначала изменить раскладку клавиатуры на "RU", потом уже далее выполнять что нужно.Как это делается? "Пример тут" В Вашем случае, примерно так должно выглядеть:
[vba]
Код
#If VBA7 Then ' тут объявление API функции Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long #Else Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long #End If Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721 '------- это должно быть в самом верху модуля------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Columns(5)) Is Nothing Then Dim strPath As String, lngInstr As Long 'вот эта строчка переведёт раскладку клавиатуры в "Ru" Dim Xlng As Long Xlng = ActivateKeyboardLayout&(kb_lay_ru, 0) ' далее, ваш макрос работает Cancel = True If Target.Value <> "" Then Exit Sub strPath = InputBox("Вставьте путь файла:") If strPath = "" Then Exit Sub strPath = Mid(strPath, 2, Len(strPath) - 2) lngInstr = InStrRev(strPath, "\") Target.Value = "=HYPERLINK(" & """" & strPath & """" & "," & """" & Mid(strPath, lngInstr + 1) & """" & ")" End If End Sub
"Допилить" можно. Нужно в коде макроса сначала изменить раскладку клавиатуры на "RU", потом уже далее выполнять что нужно.Как это делается? "Пример тут" В Вашем случае, примерно так должно выглядеть:
[vba]
Код
#If VBA7 Then ' тут объявление API функции Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long #Else Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long #End If Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721 '------- это должно быть в самом верху модуля------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Columns(5)) Is Nothing Then Dim strPath As String, lngInstr As Long 'вот эта строчка переведёт раскладку клавиатуры в "Ru" Dim Xlng As Long Xlng = ActivateKeyboardLayout&(kb_lay_ru, 0) ' далее, ваш макрос работает Cancel = True If Target.Value <> "" Then Exit Sub strPath = InputBox("Вставьте путь файла:") If strPath = "" Then Exit Sub strPath = Mid(strPath, 2, Len(strPath) - 2) lngInstr = InStrRev(strPath, "\") Target.Value = "=HYPERLINK(" & """" & strPath & """" & "," & """" & Mid(strPath, lngInstr + 1) & """" & ")" End If End Sub