VBA - Makro do Excela 2007 wstawiające zdjęcie jako komentarz

Dla specjalistów Programowanie
#1

Witam, 

Szperałem w internecie, lecz nie mogę sobie poradzić z pewną sprawą. Jako, że nie znam VBA to przyznam szczerze, że trochę błądzę po internetach.

Chodzi o to, że w kolumnie A (dajmy na to, że zakres komórek to A2:A1000) wartości są linkami/hiperłączami do zdjęć umieszczonych w necie. “Podejrzenie” zdjęcia jest możliwe po kliknięciu na łącze - w efekcie otwieramy zakładkę z obrazem w przeglądarce. Jest to uciążliwe gdyż zdjęć jest po prostu zbyt dużo.

Prosiłbym o pomoc- chciałbym osiągnąć taki efekt, aby po najechaniu na daną komórkę zdjęcie wyświetliło się jako komentarz.

Będę też wdzięczny - jeśli ktoś z was posiada wiedzę, gdzie można znaleźć w internecie dobry (przystępny i wartościowy) kurs do nauki VBA dla początkujących?

Z góry dziękuję i pozdrawiam.

Walczę i znalazłem takie makro (http://www.mrexcel.com/forum/excel-questions/382506-insert-image-into-cell-internet-3.html), gdzie problemem jest (u mnie) ten fragment:

With ActiveSheet.Shapes(strPicFileName)
.LockAspectRatio = msoFalse
.Height = cCell.Height
.Width = cCell.Width
End With

Po jego usunięciu nie wyskakuje żaden błąd, lecz jedyne co się dzieje to  tyle że wszystkie hiperłącza z zaznaczenia są zamieniane na tekst. 

Wyjaśnione = makro dla MSO 2003, a ja mam 2007 - po zapisaniu w formacie dla 97-2003 makro działa jak ta lala (tyle że konwersja wyświetla info o możliwym braku danych w arkuszu)… 

Proszę zatem, o pomoc z przerobieniem tego makra dla Excela 2007 - ja jestem za cienki w uszach na ten temat

#2

http://stackoverflow.com/questions/21396983/add-image-as-comment-vba

#3

Co do makr w Excel 2007 i nowszych, to może tego nie wiesz (i dlatego masz problem), ale takie pliki (arkusze z makrami) musisz zapisywać w formacie .xlxm, a nie .xlsx

#4

Dzięki za odpowiedzi.

Byłem wczoraj już padnięty i nie napisałem najważniejszego, że to makro, które znalazłem pobiera i wkleja zdjęcia do arkusza, a nie tworzy komentarzy wypełnionych obrazem… ;-D

Trochę to kłopotliwe bo zmienia mi rozmiar komórki, a tego chciałbym uniknąć.

@pablo_wawa: Dzięki za uwagę - jednak makro chciałbym wykorzystać jednorazowo (jak na razie). Czytałem też, że można makra zapisywać w pliku “PERSONAL” i działają one wtedy w każdym skoroszycie.

 

Znalazłem to wczoraj też między innymi - niestety nie działa to u mnie (Pobranie właściwości Insert klasy Pictures nie jest możliwe).

Czytałem gdzieś że w 2007 wypełnienie komentarza obrazem z URL nie jest możliwe (należy najpierw go pobrać i wczytać niejako plik lokalny) - czy to prawda?

Ostatecznie znalezione przeze mnie rozwiązanie jest lepsze niż nic. Czekam jednak na ciekawe pomysły. Z góry dzięki.

#5

Pytałeś o kurs vba, ja byłem kilka miesięcy temu na kursie stacjonarnym tutaj http://itschool.pl/szkolenia/microsoft-office/vba/ i byłem bardzo zadowolony, udało mi się odbyć ten kurs vba za darmo, bo opłacił go mój pracodawca. Potrzebowałem poznać tajniki vba na potrzeby pracy, dlatego go sfinansował

#6

Makro (do którego odnosi link http://www.mrexcel.com/fomru…) nie wstawia obrazu do komentarza tylko jako obraz do komórki - niestety (bo też szukam tego rozwiązania).

Poniżej rozwiązanie jakie obecnie stosuje i wydaje mi się ciekawsze.
Pokleiłem ciut różne rozwiązania ale działa dosyć nieźle - lekko modyfikowałem na potrzeby publikacji ale powinno działać

Sub IMP_ZDJĘĆ()

Dim Filename$, place As Range, myPic As Object, kom$
Dim chack As Boolean
Dim wiersz As Integer

ActiveSheet.Name = “Name_1”

wiersz = 1 'podaj nr wiersza z naglówkami
Nazwa_nagłówka_kolumny = “Zdjęcia” ’ podaj nazwę

icol = Application.CountA(Worksheets(“Name_1”).Rows(wiersz))
irow = Application.CountA(Worksheets(“Name_1”).Columns(1)) - 1 + wiersz

With Fotki

    For i = 1 To icol Step 1
    Cells(wiersz, i).Select
   nag = ActiveCell.Value
    If nag = Nazwa_nagłówka_kolumny Then
    Miejsce = Mid(ActiveCell.Address, 2, 2)
    GoTo ex
    
    '=MID(RC[-3],2,2)
    Else
    'nothing
    End If
    
    Next i

End With

ex:

'For Each place In Range(“ad2:ad” & Cells(Rows.Count, “ad”).End(xlUp).Row) ’ zamian zakresu
For Each place In Range(Miejsce & wiersz + 1 & “:” & Miejsce & Cells(Rows.Count, Miejsce).End(xlUp).Row) ’ zamian zakresu

fot = place.Value
kom = place.Address 'zmiana położenia grafiki
’fot = place.Offset(, -1).Value
’kom = place.Offset(, -1).Address 'zmiana położenia grafiki

'Filename = “XXXXXX” & fot 'trzeba uzupełnić odnośnik do folderu
Filename = ThisWorkbook.Path & “” & fot

If FileExists(Filename) = True And fot <> Empty Then

Rows(wiersz + 1 & ":" & irow).Select
Selection.RowHeight = 70
Columns(Miejsce & ":" & Miejsce).Select
Selection.ColumnWidth = 15

Set myPic = ActiveSheet.Pictures.Insert(Filename)
chack = True

With myPic
    .Top = Range(kom).Top
    .Left = Range(kom).Left
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = Range(kom).RowHeight
    .ShapeRange.Width = Range(kom).Width
End With

End If

Next

Set myPic = Nothing

Range(“AD1”).Select

If chack = True Then
MsgBox “Wykonano import zdjęć”, vbInformation
Else
MsgBox “Nie wykonano importu”, vbInformation
End If

End Sub
Public Function FileExists(FilePath As String) As Boolean
On Error GoTo blad
FileExists = Len(Dir(FilePath, vbDirectory Or vbHidden Or vbSystem)) > 0
Exit Function
blad:
FileExists = False
End Function

#7

Bardzo dziękuję za zainteresowanie. Udało mi się troszkę zmodyfikować znaleziony kod (zbędne wiersze zmieniłem w komentarze i ich nie usuwałem) i efekt finalny został osiągnięty:
LINKI PRZEKSZTAŁCANE SĄ W OBRAZY - DZIAŁA W OFFICE 2007 (NOWSZE BĘDĘ MUSIAŁ SPRAWDZIĆ)
Poniżej dane kodu:
’******************************
’* ConvertHLinksToCellPics *
’* Programmer: Ron Coderre *
’* Last Update: 07-Apr-2009 *
’******************************

Summary

Sub Wygeneruj_komenty_z_linku()
Dim cCell As Range
Dim rngSelection As Range
Dim strHLink As String
Dim cComment As Comment
Dim strPicFileName As String

Const sglRowHgt As Single = 105
Const sglColWidth As Single = 17

For Each cCell In Selection

  If cCell.Value <> "" Then
     'The cell is not blank
     With cCell
        'Store the hyperlink target
        strHLink = .Value

        If strHLink <> "" Then

           'Build a picture shape
           If InStrRev(strHLink, "/") > 0 Then
              ' cell contains a web hyperlink location
              strPicFileName = Mid(strHLink, InStrRev(strHLink, "/") + 1)
           ElseIf InStrRev(strHLink, "/") > 0 Then
              ' cell contains a file hyperlink location
              strPicFileName = Mid(strHLink, InStrRev(strHLink, "\") + 1)
           Else  ' cell does NOT contain a hyperlink location
              strPicFileName = ""
           End If

           If strPicFileName <> "" Then ' Process the link location
             'Set the row height to the value at the top of this procedure
             cCell.ColumnWidth = sglColWidth
             cCell.RowHeight = sglRowHgt

             strPicFileName = "pic_" & cCell.Row & cCell.Column

             InsertComFromFile _
                strFileLoc:=strHLink, _
                rDestCells:=cCell, _
                blnFitInDestHeight:=True, _
                strPicName:=strPicFileName

             'Make the image slightly smaller than the cell; adds a thin, black border around it
             'With ActiveSheet.Shapes(strPicFileName)
                '.LockAspectRatio = msoFalse
                '.Height = cCell.Height - 4
                '.Width = cCell.Width - 6
                '.Line.Weight = 0
                '.Line.ForeColor.RGB = RGB(255, 255, 255)
             'End With
             'Convert the hyperlinks back to normal text and changing the text color to white (= invisible)
             'cCell.Hyperlinks.Delete
             'cCell.Font.Color = RGB(0, 0, 0)
           Else
              'cell does not contain a link location...continue to the next cell
           End If ' hyperlink location test
        End If
     End With
  End If

Next cCell
End Sub
’******************************
’* InserPicFromFile *
’* Programmer: Ron Coderre *
’* Last Update: 07-Apr-2009 *
’******************************
Sub InsertComFromFile( _
strFileLoc As String, _
rDestCells As Range, _
blnFitInDestHeight As Boolean, _
strPicName As String)
Dim oNewPic As Shape
Dim shtWS As Worksheet
Dim Kompresja As CommandBarControl
Set shtWS = rDestCells.Parent

On Error Resume Next
’Delete the named picture (if it already exists)
shtWS.Shapes(strPicName).Delete
rDestCells.AddComment
rDestCells.Comment.Visible = False
rDestCells.Comment.Shape.Height = 150
rDestCells.Comment.Shape.Width = 150
rDestCells.Comment.Shape.Fill.UserPicture PictureFile:=strFileLoc

On Error Resume Next
’With rDestCells
’Create the new picture and reposition it to the center of the cell
’Set oNewPic = ActiveSheet.Shapes.AddShape( _
Type:=msoShapeRectangle, _
Left:=.Left + 3, Top:=.Top + 2, Width:=.Width - 1, Height:=.Height - 1)
'End With 'rDestCells
With oNewPic
.Fill.UserPicture PictureFile:=strFileLoc
’Maintain original aspect ratio of the image
Set Kompresja = Application.CommandBars.FindControl(ID:=6382)
Application.SendKeys "{TAB}"
Application.SendKeys "{UP}"
Application.SendKeys "%e~"
Kompresja.Execute
Set Kompresja = Nothing

    .LockAspectRatio = msoTrue
     .Placement = xlFreeFloating
            If blnFitInDestHeight = True Then
        'Resize the picture to fit in the destination cells
        .Height = .Height - 1
    End If
     'Assign the desired name to the picture
  oNewPic.Name = strPicName
End With 'oNewPic

End Sub