Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Вставить картинку в примечание и создать на нее ссылку - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставить картинку в примечание и создать на нее ссылку (Макросы/Sub)
Вставить картинку в примечание и создать на нее ссылку
MrFrai1992 Дата: Воскресенье, 12.01.2020, 17:21 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Начну чуть издалека... Со временем собралась довольно обширная библиотека аудио и просто электронных книг. Как-то захотелось навести в ней порядок и создать что-то вроде картотеки. Попробовав несколько специализированных программ так ничего для себя и не подобрал чтобы полностью устраивало. В итоге вернулся к родному MS Excel)
Так вот и подобрался к сути) В одном из столбцов я решил вставлять ссылку на оригинал обложки книги и уменьшенную копию в примечание к ячейке. Поискал на форуме что-то похожее... нашел пару тем... вроде получилось почти все.
[vba]
Код

Sub AddImage()
    Dim ImaFile$
    Dim w, ww As Long
    Dim h, hh As Long
    'считываем путь к файлу картинки
    If Selection.Cells.Count > 1 Then Exit Sub
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        ImaFile = .SelectedItems(1)
    End With
                        
        w = LoadPicture(ImaFile).Width       'размер
        h = LoadPicture(ImaFile).Height
        If h / w > w / h Then
        ww = 2
        hh = h / w * 3.8
        Else
        ww = 2
        hh = w / h * 3.8
        End If
        
    On Error GoTo nexterr
    ActiveCell.ClearComments
            With ActiveCell.AddComment.Shape   'заливаем картинку
            .Fill.UserPicture (ImaFile)
            .ScaleWidth ww, msoFalse, msoScaleFromTopLeft
            .ScaleHeight hh, msoFalse, msoScaleFromTopLeft 'корректируем размер
        End With
    ActiveCell.FormulaR1C1 = "ГИПЕРССЫЛКА(" & """" & ImaFile & """" & ";" & """" & "Cover" & """" & ")"
    Exit Sub
nexterr:
    MsgBox "Можно выбирать только изображения!", vbCritical, "Ошибка"
    ActiveCell.ClearComments
      
    
End Sub
[/vba]
Основная проблема у меня возникла с этой строчкой ActiveCell.FormulaR1C1 = "ГИПЕРССЫЛКА(" & """" & ImaFile & """" & ";" & """" & "Cover" & """" & ")"
Если добавляю знак "равно" ( ActiveCell.FormulaR1C1 = "=ГИПЕРССЫЛКА(" ... ), то код перестает работать (выбивает ошибку).
В другом своем "проекте" использовал такой же синтаксис и все было нормально. Там тоже макросом вставлялась в ячейку формула.
Помогите пожалуйста найти ошибку.
Файлик прикрепить не могу, т.к. не проходит по лимиту 100 Кб
Вот на него ссылка из моего облака картотека.rar

P.S. буду рад предложениям по улучшению "Картотеки" :)
 
Ответить
СообщениеНачну чуть издалека... Со временем собралась довольно обширная библиотека аудио и просто электронных книг. Как-то захотелось навести в ней порядок и создать что-то вроде картотеки. Попробовав несколько специализированных программ так ничего для себя и не подобрал чтобы полностью устраивало. В итоге вернулся к родному MS Excel)
Так вот и подобрался к сути) В одном из столбцов я решил вставлять ссылку на оригинал обложки книги и уменьшенную копию в примечание к ячейке. Поискал на форуме что-то похожее... нашел пару тем... вроде получилось почти все.
[vba]
Код

Sub AddImage()
    Dim ImaFile$
    Dim w, ww As Long
    Dim h, hh As Long
    'считываем путь к файлу картинки
    If Selection.Cells.Count > 1 Then Exit Sub
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        ImaFile = .SelectedItems(1)
    End With
                        
        w = LoadPicture(ImaFile).Width       'размер
        h = LoadPicture(ImaFile).Height
        If h / w > w / h Then
        ww = 2
        hh = h / w * 3.8
        Else
        ww = 2
        hh = w / h * 3.8
        End If
        
    On Error GoTo nexterr
    ActiveCell.ClearComments
            With ActiveCell.AddComment.Shape   'заливаем картинку
            .Fill.UserPicture (ImaFile)
            .ScaleWidth ww, msoFalse, msoScaleFromTopLeft
            .ScaleHeight hh, msoFalse, msoScaleFromTopLeft 'корректируем размер
        End With
    ActiveCell.FormulaR1C1 = "ГИПЕРССЫЛКА(" & """" & ImaFile & """" & ";" & """" & "Cover" & """" & ")"
    Exit Sub
nexterr:
    MsgBox "Можно выбирать только изображения!", vbCritical, "Ошибка"
    ActiveCell.ClearComments
      
    
End Sub
[/vba]
Основная проблема у меня возникла с этой строчкой ActiveCell.FormulaR1C1 = "ГИПЕРССЫЛКА(" & """" & ImaFile & """" & ";" & """" & "Cover" & """" & ")"
Если добавляю знак "равно" ( ActiveCell.FormulaR1C1 = "=ГИПЕРССЫЛКА(" ... ), то код перестает работать (выбивает ошибку).
В другом своем "проекте" использовал такой же синтаксис и все было нормально. Там тоже макросом вставлялась в ячейку формула.
Помогите пожалуйста найти ошибку.
Файлик прикрепить не могу, т.к. не проходит по лимиту 100 Кб
Вот на него ссылка из моего облака картотека.rar

P.S. буду рад предложениям по улучшению "Картотеки" :)

Автор - MrFrai1992
Дата добавления - 12.01.2020 в 17:21
Dmitriy_37 Дата: Воскресенье, 12.01.2020, 19:42 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 10
Репутация: 3 ±
Замечаний: 0% ±

Excel 2010
Добрый день!
Попробуйте так

[vba]
Код
Sub AddImage()
    Dim ImaFile$
    Dim w, ww As Long
    Dim h, hh As Long
    Dim wsAct As Worksheet, rCellAct As Range
    'считываем путь к файлу картинки
    If Selection.Cells.Count > 1 Then Exit Sub
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        ImaFile = .SelectedItems(1)
    End With
                        
        w = LoadPicture(ImaFile).Width       'размер
        h = LoadPicture(ImaFile).Height
        If h / w > w / h Then
        ww = 2
        hh = h / w * 3.8
        Else
        ww = 2
        hh = w / h * 3.8
        End If
        
    On Error GoTo nexterr
    Set wsAct = ThisWorkbook.ActiveSheet
    Set rCellAct = ActiveCell
    rCellAct.ClearComments
    With rCellAct.AddComment.Shape   'заливаем картинку
        .Fill.UserPicture (ImaFile)
        .ScaleWidth ww, msoFalse, msoScaleFromTopLeft
        .ScaleHeight hh, msoFalse, msoScaleFromTopLeft 'корректируем размер
    End With
    wsAct.Hyperlinks.Add rCellAct, ImaFile, , , "Cover"
    Exit Sub
nexterr:
    MsgBox "Можно выбирать только изображения!", vbCritical, "Ошибка"
    ActiveCell.ClearComments
      
    
End Sub
[/vba]
 
Ответить
СообщениеДобрый день!
Попробуйте так

[vba]
Код
Sub AddImage()
    Dim ImaFile$
    Dim w, ww As Long
    Dim h, hh As Long
    Dim wsAct As Worksheet, rCellAct As Range
    'считываем путь к файлу картинки
    If Selection.Cells.Count > 1 Then Exit Sub
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        ImaFile = .SelectedItems(1)
    End With
                        
        w = LoadPicture(ImaFile).Width       'размер
        h = LoadPicture(ImaFile).Height
        If h / w > w / h Then
        ww = 2
        hh = h / w * 3.8
        Else
        ww = 2
        hh = w / h * 3.8
        End If
        
    On Error GoTo nexterr
    Set wsAct = ThisWorkbook.ActiveSheet
    Set rCellAct = ActiveCell
    rCellAct.ClearComments
    With rCellAct.AddComment.Shape   'заливаем картинку
        .Fill.UserPicture (ImaFile)
        .ScaleWidth ww, msoFalse, msoScaleFromTopLeft
        .ScaleHeight hh, msoFalse, msoScaleFromTopLeft 'корректируем размер
    End With
    wsAct.Hyperlinks.Add rCellAct, ImaFile, , , "Cover"
    Exit Sub
nexterr:
    MsgBox "Можно выбирать только изображения!", vbCritical, "Ошибка"
    ActiveCell.ClearComments
      
    
End Sub
[/vba]

Автор - Dmitriy_37
Дата добавления - 12.01.2020 в 19:42
MrFrai1992 Дата: Воскресенье, 12.01.2020, 20:15 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Dmitriy_37, попробовал, но все равно ошибка.
Run-time error '424':
Object required
 
Ответить
СообщениеDmitriy_37, попробовал, но все равно ошибка.
Run-time error '424':
Object required

Автор - MrFrai1992
Дата добавления - 12.01.2020 в 20:15
MrFrai1992 Дата: Воскресенье, 12.01.2020, 20:18 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Dmitriy_37, извините невнимательно код прочитал) Все работает спасибо!
 
Ответить
СообщениеDmitriy_37, извините невнимательно код прочитал) Все работает спасибо!

Автор - MrFrai1992
Дата добавления - 12.01.2020 в 20:18
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставить картинку в примечание и создать на нее ссылку (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2020 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!