compression automatique d'image dans excel

compression automatique d'image dans excel - VB/VBA/VBS - Programmation

Marsh Posté le 08-11-2005 à 16:08:18    

Voici le code, la partie qui me pose un problème se trouve vers la fin (en rouge)
 
Ma photo est inséré dans excel, redimentionné mais pas compressé
 
Sub photo_input()
On Error Resume Next
 
x = ActiveCell.Column
y = ActiveCell.Row
If y >= 1 And x >= 1 Then
 
choixphoto = Application.GetOpenFilename("Picture (*.jpg), *.jpg" )
 
pos1 = 1
For i = 1 To 100
posx = pos1 + 1
  pos1 = InStr(pos1 + 1, choixphoto, "\" )
  If pos1 = 0 Then Exit For
Next i
 
    np = LCase(Mid(choixphoto, posx, 20))
    ActiveSheet.Range("AR1" ).Value = np
    ActiveCell.Value = Image & ": " & np
    ActiveSheet.Pictures.Insert(choixphoto).Select
     
    Selection.ShapeRange.LockAspectRatio = msoTrue
    'hauteur de l'image
    Selection.ShapeRange.Width = 305
    x = Selection.ShapeRange.Height
    Selection.ShapeRange.Name = np
    'Décalage avec le haut de la cellule
    Selection.ShapeRange.IncrementTop
    'Décalage avec la gauche de la cellule
    Selection.ShapeRange.IncrementLeft
    'Sélectionne la colonne de la cellule active
    ActiveCell.EntireColumn.Select
    'Définit la largeur de la colonne à 12.2
    Selection.ColumnWidth = 60
    'Sélectionne la ligne
    Rows(y & ":" & y).Select
    'Définit la hauteur de la ligne à 13
    Selection.RowHeight = 235
     
    'remet le curseur dans la colonne A ligne Y
'    Range("A" & y).Select
 
    'compression des photos
    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#

 
 
End If
End Sub


Message édité par beberf1 le 22-11-2005 à 10:17:14
Reply

Marsh Posté le 08-11-2005 à 16:08:18   

Reply

Marsh Posté le 08-11-2005 à 16:25:53    

petite info que j'ai oublié:
 
le but de la macro est d'automatiser la fonction que propose déjà excel
 
dans excel sur une image il faut faire format de l'image puis compresser puis choisir toutes les images et format web.
 
voilà

Reply

Marsh Posté le 14-11-2005 à 13:43:10    

help me

Reply

Marsh Posté le 15-11-2005 à 15:09:28    

Il semblerait qu'il ne soit pas possible d'utiliser la fonction compress de facon programmatique ...


---------------
Ce qui est affirmé sans preuve peut être nié sans preuve.
Reply

Marsh Posté le 16-11-2005 à 11:53:07    

c'est vraiement pas cool

Reply

Marsh Posté le 16-11-2005 à 11:53:25    

tu crois qu'il y a une autre solution

Reply

Marsh Posté le 16-11-2005 à 12:21:20    

Je n'en sais rien ... tout ce que j'ai lu comme moyen de contourner le problème est d'utiliser un macro pour appeler la fenêtre du compress ... c'est pas le pied ...


---------------
Ce qui est affirmé sans preuve peut être nié sans preuve.
Reply

Marsh Posté le 16-11-2005 à 13:37:38    

ok merci si je trouve quelquechose je mettrais les infos

Reply

Marsh Posté le 18-11-2005 à 15:43:00    

Bonjour vobiscum
 
est-ce que tu as toujours sous le coude la macro qui permet de contourner le problème en appelant la fenêtre du compress
 
@+

Reply

Marsh Posté le 18-11-2005 à 20:48:41    

beberf1 a écrit :

Bonjour vobiscum
 
est-ce que tu as toujours sous le coude la macro qui permet de contourner le problème en appelant la fenêtre du compress
 
@+


 
En fait, j'ai inséré une image via la fonction du menu "insertion->image->à partir du fichier" puis j'ai affecté une macro à l'image lorsque l'on clique dessus:
 

Code :
  1. Sub Image1_QuandClic()
  2.     Dim cbc As Office.CommandBarControl
  3.     Set cbc = CommandBars.FindControl(ID:=6382)
  4.     cbc.Execute
  5.     Set cbc = Nothing
  6. End Sub


 
la macro ouvre la fenêtre de dialogue du "compress" ...
 
Si ca peut t'être utile  :wahoo:


---------------
Ce qui est affirmé sans preuve peut être nié sans preuve.
Reply

Marsh Posté le 18-11-2005 à 20:48:41   

Reply

Marsh Posté le 22-11-2005 à 10:16:53    

ok merci

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed