Foto invoegen en bestandsgrootte verkleinen

[Albatros]

Hoi,

Via onderstaande makro, gevonden op dit forum :thumb:, kan ik foto's invoegen en verkleinen. Echter de oorspronkelijke bestandsgrootte van bv 500 kB per foto blijft bestaan. Is het mogelijk om binnen excel, de foto-bestanden te verkleinen naar bv. 30 kB per foto?

Sub Insert_Pict()
   'Courtesy of Dave Hawley of Ozgrid.com
    Dim Pict() As Variant
    Dim ImgFileFormat As String
    Dim lRow As Long, lLoop As Long
    Dim lTop As Long
    Dim sShape As Shape
     
    ActiveSheet.Protect False, False, False, False, False
    ImgFileFormat = "Image Files jpg (*.jpg),*.jpg,(*.bmp),others, tif (*.tif),*.tif"
     
GetPict:
    Pict = Application.GetOpenFilename(ImgFileFormat, MultiSelect:=True)
     'Note you can load in nearly any file format
    If Not IsArray(Pict) Then
        Debug.Print "No files selected."
        Exit Sub
    End If
     
    lRow = 10
    For lLoop = LBound(Pict) To UBound(Pict)
         
        lTop = Cells(lRow, "F").Top
        Set sShape = ActiveSheet.Shapes.AddPicture(Pict(lLoop), msoFalse, msoCTrue, Cells(1, 6).Left, lTop, 96, 75)
                            'expression.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
       lRow = lRow + 1
Next lLoop
End Sub

Albatros

 

[danny147]

Beste Albatros

Als je werkt met excel 2007, daar zit deze mogelijkheid erin.

Groetjes Danny. :thumb:

 

[Albatros]

Danny,

Bedankt voor je reactie.
Helaas heb ik geen 2007 versie.
Ik wilde nl. een lijst maken met verbeteringsvoorstellen, en als deze opgelost waren, middels autofilter, alleen nog de openstaande akties laten zien.
op het einde van het jaar kan ik alsnog een totaaloverzicht maken. Echter met ca. 500 foto's in een excelbestand van ca. 500 kB per foto, wordt dit (om te e-mailen) een klein drama
Moet dus wat anders verzinnen.

Albatros

 

[Albatros]

Danny heeft mij toch op een idee gezet....

Als ik in excel op een foto klik, en vervolgens, opmaak, figuur, figuur comprimeren, en dan vervolgens op Resolutie wijzigen web/scherm, wordt de resolutie verlaagd van 200 naar 96 dpi.(toepassen op alle figuren in het document)
Mijn test bestandje wordt dan verkleind van 925 naar 71 kb.
Perfect!
Maar... als ik dit met een macro-recorder opneem, gebeurd er niets!
[

Sub Macro1()

    Application.Goto Reference:="R3C1"
    ActiveSheet.Shapes("Picture 1").Select
    Selection.ShapeRange.PictureFormat.Brightness = 0.5
    Selection.ShapeRange.PictureFormat.Contrast = 0.5
    Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
    Selection.ShapeRange.PictureFormat.CropLeft = 0#
    Selection.ShapeRange.PictureFormat.CropRight = 0#
    Selection.ShapeRange.PictureFormat.CropTop = 0#
    Selection.ShapeRange.PictureFormat.CropBottom = 0#
    Application.Goto Reference:="R1C1"
End Sub

Kan iem. mij hier mee verder helpen?

Albatros

 

[Wigi]

Klopt de naam van de figuur wel? (Picture 1)

 

[Albatros]

Wigi,

Klopt de naam van de figuur wel? (Picture 1)

Vlgs de macro-recorder klopt dit idd.

Albatros

 

[Wigi]

Doe dan maar een voorbeeldbestandje met een aantal foto's als test.

 

[Albatros]

Hoi Wigi,

Doe dan maar een voorbeeldbestandje met een aantal foto's als test.

De bestaande foto's waren te groot. Van internet heb ik een kleiner voorbeeld genomen met één foto.
Als ik handmatig de procedure van het comprimeren uitvoer, gaat het goed. Met de makro-recorder doe ik hetzelfde, echter zonder resultaat :shocked:

Albatros

 

[Warme bakkertje]

Dit kan je helaas niet programmeren in VBA. Onderstaande code is een shortcut naar het dialoogvenster zodat je niet alle handelingen moet uitvoeren. Je kan misschien eens experimenteren met SendKeys om het nog verder te automatiseren maar dit is niet zo'n betrouwbare methode.

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

Mvg

Rudi

 

[Albatros]

Hoi Rudy,

Dit komt al aardig in de richting. (Had nog nooit gehoord van sentkeys)

Dit kan je helaas niet programmeren in VBA.

Als het idd niet te programmeren valt, dan hou ik het hier op. :thumb:

Heb ik nog één aanvullende vraag:
Hoe kan ik de allereerste code (23 maart 2009) aanpassen, zodat de foto's vanaf de regel komen te staan waar op dat moment de curser staat, (om zo een vervolg in de rapportage te krijgen), event. vooraf gegaan met een vraag in een MSG-box?

Albatros

 

[Warme bakkertje]

Mijn excuses voor het late antwoord (druk, druk)

Sub Insert_Pict()
   'Courtesy of Dave Hawley of Ozgrid.com
    Dim Pict() As Variant
    Dim ImgFileFormat As String
    Dim lLoop As Long
    Dim sShape As Shape
     
    ActiveSheet.Protect False, False, False, False, False
    ImgFileFormat = "Image Files jpg (*.jpg),*.jpg,(*.bmp),others, tif (*.tif),*.tif"
     
GetPict:
    Pict = Application.GetOpenFilename(ImgFileFormat, MultiSelect:=True)
     'Note you can load in nearly any file format
    If Not IsArray(Pict) Then
        Debug.Print "No files selected."
        Exit Sub
    End If
    For lLoop = LBound(Pict) To UBound(Pict)
         Set sShape = ActiveSheet.Shapes.AddPicture(Pict(lLoop), msoFalse, msoCTrue, ActiveCell.Left, ActiveCell.Top, 96, 75)
                            'expression.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
        ActiveCell.Offset(1, 0).Select
    Next lLoop
End Sub

Voor wat betreft de MsgBox zal je toch even moeten verduidelijken wat je wil bereiken.

Mvg

Rudi

 

[Albatros]

Rudi,

Bedankt voor je reactie.
Op de een of andere manier werkt de makro niet.
Daarom heb ik het bestand toegevoegd.
Stel ik klik op de knop en voeg 6 fotos toe, die komen te staan in F6 t/m F15.
Vervolgens klik ik weer op de knop, en er verschijnt een MsgBox met de vraag, of de curser op de plaats staat waar de volgende fotos ingevoegd moeten worden, dus van F16 t/m Fxx.

Ik hoop dat het zo iets meer duidelijker is.

Albatros

 

[Warme bakkertje]

Bij deze

Mvg

Rudi

 

[Albatros]

Rudi,

Amazing....
Dit is wat ik bedoelde! :thumb: :thumb:
Ik hoop dat ik je geen slapeloze nachten bezorgd heb, gezien het tijdstip dat je reacties plaatst!

In iedergeval; bedankt! :thumb:

Albatros

 

[Albatros]

Hoi,

Als de moderator er mee eens is, wil ik deze opgeloste vraag nog een keer "open breken".

Warme bakkertje had mij zeer goed geholpen met de twee makro's, die perfect werken in een test omgeving. :thumb:
Bij 6 foto's invoegen, gaat de bestandsgrootte van 939 naar 49 kb. :thumb:
Bij 9 foto's invoegen, gaat de bestandsgrootte van 940 naar 490 kb.
Bij 12 foto's invoegen, gaat de bestandsgrootte van 940 naar.. 940 kb.

Loop ik hiermee tegen de grenzen van excel, of is er iets over het hoofd gezien?
In de bijlage het bestand met de twee makro's, maar zonder foto's (vanwege de grootte)

Albatros