productsheet maken plaatjes importeren met Macro

[lapzwans]

Hallo Allemaal,

Op mijn werk komt het geregeld voor dat ik een reeks producten in een tabel in excel moet plaatsen voor een client.

Momenteel zit ik vast in een Excel Document waarin in ik 250 images moet importeren.
De bedoeling is dat de plaatjes in kolom G terecht komen, in Kolom B staan de barcodes.

De images zijn allemaal gelijknamig aan de barcodes van het product.
Op het moment heb ik een VBA code waarin ik wel de plaatjes kan importeren maar ze vallen allemaal in dezelfde kolom.

Ik heb de volgende code gebruikt:

Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

Uiteindelijk wil ik dus middels VBA in een keer de plaatjes per rij in de juiste kolom gieten, is dit mogelijk? Zo ja hoe?

Heel erg bedankt voor het lezen tot zover

Mvg,

Lapzwans.

 

[edmoor]

Je kan in VBA de Top en Left van een cel ophalen. Die informatie gebruik je vervolgens om je plaatjes te positioneren.

 

[lapzwans]

Je kan in VBA de Top en Left van een cel ophalen. Die informatie gebruik je vervolgens om je plaatjes te positioneren.

Mijn de rij is 100 hoog en kolom is 16 breed, ik ben geen wonder in VBA; hoe zou dit er textueel uit moeten zien?

Stel dat ik van de 250 plaatjes er maar 200 gevonden heb tot dusver laat 't script dan ook cellen leeg?

 

[edmoor]

Ik had het niet over een rij en een kolom maar over een cel. Je weet kennelijk in welke cel je een plaatje wil hebben. Van die cel haal je dan de Top en Left informatie op en gebruikt dat om je plaatje te positioneren. Plaatjes worden niet in een cel gezet maar op een positie in de sheet.

Kijk hier eens naar:
http://www.exceltip.com/general-topics-in-vba/insert-pictures-using-vba-in-microsoft-excel.html

 

[lapzwans]

Het probleem in mijn code is het feit dat de afbeeldingen wel in de juiste kolom terecht komen, alleen deze selecteert de eerste image in de map en niet de naam van het plaatje voor de juiste volgorde, als dit verholpen is dan kan ik pas de size van het plaatje defineren.

Kom er niet 123 uit...

 

[Warme bakkertje]

Sub Insert_Pict1()
    Dim lRow As Long, lLoop As Long
    Dim lTop As Long, sShape As Shape
    Dim myarray As Variant, ImagePath As String
    ImagePath = "G:\Mijn documenten\"
    myarray = WorksheetFunction.Transpose(Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value)
    ActiveSheet.Protect False, False, False, False, False
    If Not IsArray(myarray) Then
        MsgBox "Geen bestanden geselecteerd."
        Exit Sub
    End If
    On Error Resume Next
    lRow = 2
    For lLoop = LBound(myarray) To UBound(myarray)
        Set sShape = ActiveSheet.Shapes.AddPicture(ImagePath & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
                Cells(1, 7).Left + 9, Cells(lRow, 7).Top + 8, 80, 60)
                            
       lRow = lRow + 1
    Next lLoop
End Sub

Pas het pad aan bij ImagePath.
Vertrekkende van Rij 2, Barcodes in kolom B en afbeeldingen dan in kolom G.

 

[lapzwans]

Ik heb de directory ingevoerd maar zie niet waar ik de vertrekkende Rij moet invoeren? Mooi schript; Zou ik hierin ook de size nog later kunnen nalopen van de plaatjes?

 

[Warme bakkertje]

Bij lRow geef je de beginrij aan.
Ik zou het eens proberen met 1 of 2 plaatjes in te voegen en te experimenteren met de 80 (breedte) en 60 (hoogte) totdat je het juiste formaat hebt om daarna alles ineens in te voegen.

 

[lapzwans]

Ik kom er niet uit... Weet niet hoe ik dit in elkaar ga flansen!

 

[Warme bakkertje]

Ik kom er niet uit... Weet niet hoe ik dit in elkaar ga flansen!

Daar hebben we ook niet veel aan om je verder te helpen.

Mijn de rij is 100 hoog en kolom is 16 breed

100 wat ? 16 wat ?
In welke directory steken de plaatjes ? Zijn het .jpg, .tiff, .bmp
Steek je bestand en enkele plaatjes in een zip-file en post het hier zodat we het eens kunnen bekijken.

 

[lapzwans]

Bij lRow geef je de beginrij aan.
Ik zou het eens proberen met 1 of 2 plaatjes in te voegen en te experimenteren met de 80 (breedte) en 60 (hoogte) totdat je het juiste formaat hebt om daarna alles ineens in te voegen.

Het importeren is gelukt, de barcode Cel was verkeerd geplaatst, is er voor de size van de images geen vast bereik in te stellen? Dat je er bijvoorbeeld voor zorgt dat de plaatjes niet uit vorm raken? en het celbereik niet overschrijden?

 

[Warme bakkertje]

experimenteren met de 80 (breedte) en 60 (hoogte) totdat je het juiste formaat hebt om daarna alles ineens in te voegen.

 

[lapzwans]

Gedaan, ik ben blij dat je zo snel reageerd

Het lukt op een groot deel van de plaatjes wel maar ze zijn niet allemaal in dezelfde verhouding, de een is een landscape en de ander portrait formaat, kan ik hier ook rekening mee houden in de code?

 

[Warme bakkertje]

Heb een oplossing gevonden maar er zal mi dan wel vertraging optreden aangezien nu elke afbeelding eerst op grootte moet gecontroleerd worden.
Zet enkele bestandsnamen in kolom B (vanaf rij 2) en test de macro in Module1.
De benodigde functies staan in de 2de module.

 

[lapzwans]

Heb een oplossing gevonden maar er zal mi dan wel vertraging optreden aangezien nu elke afbeelding eerst op grootte moet gecontroleerd worden.
Zet enkele bestandsnamen in kolom B (vanaf rij 2) en test de macro in Module1.
De benodigde functies staan in de 2de module.

Wauw dit is Vet! Thanks!

kan ik ook in het script toevoegen dat als een image niet bestaat in de directory dat er ipv een image een 0 word ingevoerd?

 

[Warme bakkertje]

Na wat onderzoek kan het simpeler zonder die extra functies.
Plus aanpassing laatste opmerking.

 

[lapzwans]

Na wat onderzoek kan het simpeler zonder die extra functies.
Plus aanpassing laatste opmerking.

Ziet er heel gelikt uit, het scheelt ontzettend, kan ik de werkmap ook opslaan van 70 mb naar een formaat van minder dan 5 MB?

Of zijn dit toch echt de plaatjes die te groot zijn?

Echt blij dat je me helpt

 

[Warme bakkertje]

opslaan van 70 mb naar een formaat van minder dan 5 MB?

Neen

zijn dit toch echt de plaatjes die te groot zijn

Niet de plaatjes te groot, enkel de grote hoeveelheid plaatjes.

 

[tkint]

Beste,

Wordt het bestand niet kleiner indien je de plaatjes ophaalt uit hetzelfde pad als het excelbestand? Uiteraard moet de VBA-code aangepast worden.

 

[Warme bakkertje]

Probeer deze eens.

XL 2007 https://support.office.com/en-NZ/Ar...-picture-5ad8ca3d-f251-4d96-a9ae-3e7ee374c91e

XL 2010 https://support.office.com/en-ca/ar...-picture-9d8de420-3beb-4481-98e9-88efa4e2fd95

Of deze

Private Sub Display_Compression_Dialog()
Dim cbc As Office.CommandBarControl
    SendKeys "{DOWN}{TAB}{UP}{TAB 3}{ENTER}"
    Set cbc = CommandBars.FindControl(ID:=6382)
    cbc.Execute
    Set cbc = Nothing
End Sub