bezoeker01
Gebruiker
- Lid geworden
- 11 jan 2016
- Berichten
- 6
Beste,
Ik heb een code gevonden waarbij het mogelijk is afbeeldingen in te voegen op basis van de celwaarde.
De code verwacht echter de juiste naam van het tabblad welke nu verschillend is per tab.
Kan de formule zo worden dat alle tabbladen worden nagelopen of dat ik meerdere tabbladen in de code kan toepassen zonder dat ik de tabs moet hernoemen?
Waarbij Set mySheet = ThisWorkbook.Sheets("naam tabblad") nu dus diverse zijn, zal gaan om 10 verschillende tabbladen
Ik heb een code gevonden waarbij het mogelijk is afbeeldingen in te voegen op basis van de celwaarde.
De code verwacht echter de juiste naam van het tabblad welke nu verschillend is per tab.
Kan de formule zo worden dat alle tabbladen worden nagelopen of dat ik meerdere tabbladen in de code kan toepassen zonder dat ik de tabs moet hernoemen?
Code:
Option Explicit
'De afmetingen van de foto's, zoals ze in de sheet staan, komen uit het voorbeeld.
'Opmerking: De originele foto's zouden ook dezelfde breedte/hoogte-verhouding moeten hebben.
Private Const Picture_Height = 100
Private Const Picture_Width = 100
'De foto's komen in de vierde kolom en de referenties staan in de vijfde kolom.
Private Const Picture_Col = 1
Private Const PictureName_Col = 2
'De gegevens starten vanaf de zesde rij.
Private Const Start_Row = 3
Sub InsertMultiplePictures()
Dim mySheet As Worksheet, Sh As Shape
Dim nRow As Integer, nLastRow As Integer
Dim cFullpathFileName As String
Set mySheet = ThisWorkbook.Sheets("naam tabblad")
'Eerst alle bestaande thumbnails verwijderen.
For Each Sh In mySheet.Shapes
Sh.Delete
Next
'Dan alle gegevensrijen aflopen en een foto invoeren waar we een geldige referentie ontmoeten.
nLastRow = LastRow(mySheet)
For nRow = Start_Row To nLastRow
cFullpathFileName = GetFullpathPictureFileName(mySheet.Cells(nRow, PictureName_Col))
If cFullpathFileName <> vbNullString Then
InsertPicture mySheet.Cells(nRow, Picture_Col), cFullpathFileName
End If
Next
End Sub
'Deze Sub plaatst een foto in de cel die als parameter doorgegeven wordt. De
'tweede parameter is de FullPath-naam van de foto.
Sub InsertPicture(ByVal myCell As Range, ByVal cPicture As String)
Dim mySheet As Worksheet, myPicture As Shape
Dim nTop As Double, nLeft As Double, rate As Double, i As Integer
'De coördinaten van de linker bovenhoek van de foto en die van de cel zijn gelijk.
With myCell
nTop = .Top + 1
nLeft = .Left
End With
'De worksheet waartoe de cel behoort, moeten we kennen.
Set mySheet = myCell.Parent
'Veronderstel dat de naam van het fotobestand OK is, maar het formaat niet. Dan zal de
'AddPicture methode een foutmelding veroorzaken.
On Error GoTo Errhandler
'Een nieuwe foto (Shape) toevoegen op de gepaste coördinaten. De syntax is:
'expression.AddPicture(FileName, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
'Om het Excel-bestand niet op te blazen gebruiken we de optie LinkToFile = True.
Set myPicture = mySheet.Shapes.AddPicture(cPicture, True, False, nLeft, nTop, Picture_Width, Picture_Height)
'De hoogte van de cell aanpassen aan de foto. Beide afmetingen zijn in points.
myCell.RowHeight = 105
'De breedte van de cel aanpassen aan de breedte van de foto.
'Probleem is dat de breedte van de cell uitgedrukt wordt in "letterbreedte" en de breedte van de foto in points.
'We kunnen de verhouding van die eenheden berekenen, maar dat moeten we enkele keren herhalen,
'Zie http://dailydoseofexcel.com/archives/2004/06/01/column-widths-in-points/
With myCell
For i = 1 To 3
rate = .ColumnWidth / .Width
.ColumnWidth = Picture_Width * rate
Next
End With
'Hyperlink toevoegen om de originele foto te openen als men op de "Thumbnail" klikt.
mySheet.Hyperlinks.Add Anchor:=myPicture, Address:=cPicture
Exit Sub
Errhandler:
myCell.Value = "Probleem met " & cPicture
End Sub
'Deze Udf geeft de bestandsnaam van de foto, compleet met Path en Extension.
Function GetFullpathPictureFileName(ByVal oCell As Range) As String
Dim cFile As String
'Als we een lege cel doorkrijgen, is het gedaan.
If IsEmpty(oCell) Then Exit Function
'De volledige naam samenstellen. We gaan er van uit dat de foto's in dezelfde
'folder staan als dit Excel-bestand. Te wijzigen als het anders moet.
cFile = ThisWorkbook.Path & "\" & oCell.Value & ".jpg"
'Als het fotobestand niet bestaat is het ook gedaan.
If Dir(cFile) = vbNullString Then Exit Function
'Als we hier geraken geven we de Fullpath-naam terug.
GetFullpathPictureFileName = cFile
End Function
'******************************************************************************
'Deze Udf geeft de laatste rij met gegevens in de sheet die als paramater wordt
'doorgegeven. Ze is gebaseerd op de "Real Last Cell", iets dat van internet
'komt en uitgevonden is omdat blijkbaar de property "UsedRange" niet altijd
'deftig werkt.
'Zie http://www.beyondtechnology.com/geeks012.shtml.
'******************************************************************************
Function LastRow(oSh As Worksheet) As Integer
Dim r As Integer
' Error-handling is here in case there is not any
' data in the worksheet
On Error Resume Next
With oSh
' Find the last real row
r = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
End With
LastRow = r
End FunctionWaarbij Set mySheet = ThisWorkbook.Sheets("naam tabblad") nu dus diverse zijn, zal gaan om 10 verschillende tabbladen
