• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Foto's importeren in excel met VBA

Status
Niet open voor verdere reacties.
J

jorn75

Gebruiker
Lid geworden
6 mrt 2012
Berichten
10
Na lang zoeken heb ik eindelijk een macro gevonden waar mee ik foto's kon importeren in excel maar helaas zet hij de foto's niet in de B kolom in de cel achter de naam van de foto maar gewoon los in de boven hoek kan iemand mij hier bij helpen.

ik zou graag zien
naam foto / foto
naam foto / foto
etc

Dit is de macro ik kom zelf niet verder als kopiëren en plakken van een macro.

Sub Macro1()
Range("a3").Select
On Error Resume Next

Do Until ActiveCell.Value = ""
Afb_naam = ActiveCell.Value
Afb_map = "c:\fotos2\00"
Afb_bestandsnaam = Afb_map & Afb_naam & ".jpg"

ActiveCell.Offset(0, 1).Select

If Dir(Afb_bestandsnaam) <> "" Then
ActiveSheet.Pictures.Insert(Afb_bestandsnaam).Name = Afb_naam
Else: ActiveCell.Value = "Foto niet aanwezig"
End If
ActiveCell.Offset(1, -1).Select
Loop
End Sub
 
Bijvoorbeeld:

Code: 
Sub Macro1()
    
    Dim rng As Range
    
    On Error Resume Next
    For Each rng In Columns(1).SpecialCells(2, 2)
        Afb_bestandsnaam = "C:\fotos2\00" & rng.Text & ".jpg"
        If Len(Dir(Afb_bestandsnaam)) Then
            With ActiveSheet.Pictures.Insert(Afb_bestandsnaam)
                .ShapeRange.LockAspectRatio = False
                .Left = rng.Offset(, 1).Left
                .Width = rng.Offset(, 1).Width
                .Top = rng.Top
                .Height = rng.Height
            End With
        Else
            rng.Offset(, 1).Value = "Foto niet aanwezig"
        End If
    Next
End Sub

Graag had ik wel uw aandacht gevraagd voor het gebruik van
Code: 
 tags wanneer u code plaatst op het forum. Dank.
 
of
Code: 
Sub snb()
    Sheets(1).Shapes.AddPicture "G:\OF\0_nummering.gif", False, True, Columns(2).Left, Rows(2).Top, Columns(2).Width, Rows(2).Height
End Sub
 
snb zei:
of
Code: 
Sub snb()
    Sheets(1).Shapes.AddPicture "G:\OF\0_nummering.gif", False, True, Columns(2).Left, Rows(2).Top, Columns(2).Width, Rows(2).Height
End Sub
Klik om te vergroten...

AddPicture was ik even uit het oog verloren, bedankt :thumb:
 
Wigi zei:
AddPicture was ik even uit het oog verloren, bedankt :thumb:
Klik om te vergroten...

Hoi allen bedankt voor jullie input, als eerst excusses voor de late reactie maar mijn zoon is een aantal weken geleden geboren en had opstart problemen dus veel tijd in het ziekenhuis geweest. Gaat nu goed met hem :thumb:

Ik heb beide macro's geprobeerd maar zoals ik al zij, ik kan kopieren en plakken VBA maar dan houd het ook wel op. Kan iemand een werkende excel posten volgens mij zijn daar veel mensen mee gebaat.

Groetjes Jorn
 
jorn75 zei:
Hoi allen bedankt voor jullie input, als eerst excusses voor de late reactie maar mijn zoon is een aantal weken geleden geboren en had opstart problemen dus veel tijd in het ziekenhuis geweest.
Klik om te vergroten...

Er is toch een zoon gebaard en geen computer? :eek:
Wel proficiat overigens.

Mijn eerdere code is kant en klaar en vervangt de jouwe.
 
Laatst bewerkt:
Wigi zei:
Er is toch een zoon gebaard en geen computer? :eek:
Wel proficiat overigens.

Mijn eerdere code is kant en klaar en vervangt de jouwe.
Klik om te vergroten...

Hey duidelijk en gelukt maar de laatste macro werkt niet voor een hele map hij kan maar 1 foto tegelijk aan.
En ik wil een hele map importeren met de naam van de foto in de eerste kollom en de foto in de tweede.
 
Code: 
Sub Insert_Pict1()
    Const Afb_map = "c:\fotos2\00\"
    myarray = WorksheetFunction.Transpose(Range("A3", Range("A" & Rows.Count).End(xlUp)).Value)
    ActiveSheet.Protect False, False, False, False, False
    If Not IsArray(myarray) Then Exit Sub
    On Error Resume Next
    lRow = 3
    For lLoop = LBound(myarray) To UBound(myarray)
        Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
                Cells(1, 2).Left + 9, Cells(lRow, 2).Top + 8, 80, 60)
        lRow = lRow + 1
    Next lLoop
End Sub
 
Warme bakkertje zei:
Code: 
Sub Insert_Pict1()
    Const Afb_map = "c:\fotos2\00\"
    myarray = WorksheetFunction.Transpose(Range("A3", Range("A" & Rows.Count).End(xlUp)).Value)
    ActiveSheet.Protect False, False, False, False, False
    If Not IsArray(myarray) Then Exit Sub
    On Error Resume Next
    lRow = 3
    For lLoop = LBound(myarray) To UBound(myarray)
        Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
                Cells(1, 2).Left + 9, Cells(lRow, 2).Top + 8, 80, 60)
        lRow = lRow + 1
    Next lLoop
End Sub
Klik om te vergroten...

Bekijk bijlage Book4.xlsm


Bedankt voor je reactie. ik heb hem geprobeerd maar er gebeurt niks. doe ik iets verkeerd? Ik heb het bestand toegevoegd
 
Om te beginnen zet je de macro in een standaardmodule, niet in ThisWorkBook.
Waar zijn de namen van de foto's, want je werkblad is leeg en zijn ze juist ?
Is de naam v/d directory waar de fotot's zich in bevinden correct ?
Als alles overeenstemt met de werkelijkheid werkt deze macro met zekerheid voor 100%(heb 'm zelf getest op een eigen dir), net zoals de macro van Wigi uiteraard wel zal werken.
 
Bekijk bijlage import fotos.xlsm
Warme bakkertje zei:
Om te beginnen zet je de macro in een standaardmodule, niet in ThisWorkBook.
Waar zijn de namen van de foto's, want je werkblad is leeg en zijn ze juist ?
Is de naam v/d directory waar de fotot's zich in bevinden correct ?
Als alles overeenstemt met de werkelijkheid werkt deze macro met zekerheid voor 100%(heb 'm zelf getest op een eigen dir), net zoals de macro van Wigi uiteraard wel zal werken.
Klik om te vergroten...
Oké als ik het dus goed begrijp moet ik ook nog een macro gebruiken om de namen van de foto's uit de map te halen en deze zet ik dan in in sheet1 A3 neer? (zie excel)
 
Laatst bewerkt:
Uit de macro in jouw 1ste post blijkt overduidelijk dat de namen al aanwezig zijn in kolom A ???????
 
Plaats eens een voorbeeldbestand waarin enkele namen staan en vermeld dan ook de dir waarin de foto's staan, want dit wordt al te gek.
Zet er ook de macro in die je aangepast hebt en gebruikt, en vermeld ook de extensie v/d fotobestanden.
 
Warme bakkertje zei:
Plaats eens een voorbeeldbestand waarin enkele namen staan en vermeld dan ook de dir waarin de foto's staan, want dit wordt al te gek.
Zet er ook de macro in die je aangepast hebt en gebruikt, en vermeld ook de extensie v/d fotobestanden.
Klik om te vergroten...

Staat in de vorige Quote import fotos.xlsm de extensie is .jpg en directory staat in de macro
 
Foto's zijn trouwens 150x200 pixels zou mooi zijn als ze de zelfde grote bleven.
 
Code: 
Const Afb_map = "Z:\Opleidingen\1. Algemeen\Organisatie L&D\6. LMS\Plusport\foto\FOTO[COLOR="#FF0000"]\[/COLOR]"
Code: 
Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop), msoFalse, msoCTrue, _
Voor wat betreft de grootte moet je maar experimenteren met de cijfers in de macro.
 
Warme bakkertje zei:
Code: 
Const Afb_map = "Z:\Opleidingen\1. Algemeen\Organisatie L&D\6. LMS\Plusport\foto\FOTO[COLOR="#FF0000"]\[/COLOR]"
Code: 
Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop), msoFalse, msoCTrue, _
Voor wat betreft de grootte moet je maar experimenteren met de cijfers in de macro.
Klik om te vergroten...


Super het werkt deze ga ik regelmatig gebruiken, hartelijkdank voor de hulp ik zal hem afmelden
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan