Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

Re-Inserer image

1 réponse
Avatar
Olivier
Bonjour =E0 tous !

En r=E9f=E9rence au message de Denis Michon"=20
<denis.michon@cgocable.ca>....

Cette fonction est vraiment terrible ! Merci !

Mais j'essaie vainement d'apporter une petite modif, mais=20
cela ne fonctionne pas !
En fait je voudrais =E0 la fin de la macro appliquer la=20
taille de l'image =E0 la taille de la cellule, =E0 savoir si=20
l'image fait 375 x 372 pixels je voudrais que ma cellule=20
soit redimensionn=E9e avec ces valeurs.

Voir le code que j'ai rajout=E9 ci dessous, marqu=E9 par $$$=20
(Les $$$ ne sont pas dans mon code c'est juste pour=20
rep=E9rer mes modifs ici !)

MERCI D'AVANCE !!!!

Olivier=20

----- Original Message -----=20
From: "Denis Michon" <denis.michon@cgocable.ca>
Newsgroups: microsoft.public.fr.excel
Sent: Saturday, November 01, 2003 5:14 PM
Subject: Re: inserer image


> Bonjour Christian,
>=20
> 'Un merci =E0 Denis Pasquier (mpfe) pour l'api que j'ai=20
modifi=E9 pour ton probl=E8me.
>=20
> Voici une fa=E7on de faire :
>=20
> Tu appelles la proc=E9dure : Sub Ins=E9rerUnImage()
>=20
> Tu prends soin de d=E9finir les variables suivantes selon=20
ton projet.
> A ) Chemin
> B ) Filtre
> C ) Feuille
> D ) Plage
>=20
>=20
> Dans le haut d'un module standard : D=E9claration de l'api
> '-------------------
> Declare Function GetOpenFileName Lib "comdlg32.dll" _
> Alias "GetOpenFileNameA" (pOpenfilename As=20
OPENFILENAME) As Long
>=20
> Private Type OPENFILENAME
> lStructSize As Long
> hwndOwner As Long
> hInstance As Long
> lpstrFilter As String
> lpstrCustomFilter As String
> nMaxCustFilter As Long
> nFilterIndex As Long
> lpstrFile As String
> nMaxFile As Long
> lpstrFileTitle As String
> nMaxFileTitle As Long
> lpstrInitialDir As String
> lpstrTitle As String
> flags As Long
> nFileOffset As Integer
> nFileExtension As Integer
> lpstrDefExt As String
> lCustData As Long
> lpfnHook As Long
> lpTemplateName As String
> End Type
>=20
> Private Function SelectAFile(Chemin As String, Optional=20
Filtre As String =3D "*.*") As String
> Dim OpenFile As OPENFILENAME, lReturn As Long, sFilter=20
As String
> OpenFile.lStructSize =3D Len(OpenFile)
> sFilter =3D "Tous les fichiers (" & Filtre & ")" & Chr
(0) & Filtre & Chr(0)
> With OpenFile
> .lpstrFilter =3D sFilter
> .nFilterIndex =3D 1
> .lpstrFile =3D String(257, 0)
> .nMaxFile =3D Len(OpenFile.lpstrFile) - 1
> .lpstrFileTitle =3D OpenFile.lpstrFile
> .nMaxFileTitle =3D OpenFile.nMaxFile
> .lpstrInitialDir =3D Chemin
> .lpstrTitle =3D "Vos images"
> .flags =3D 0
> End With
> lReturn =3D GetOpenFileName(OpenFile)
> If lReturn =3D 0 Then
> SelectAFile =3D "erann"
> Else
> SelectAFile =3D Trim(Left(OpenFile.lpstrFile, _
> InStr(1, OpenFile.lpstrFile, Chr(0)) - 1))
> End If
> End Function
>=20
>=20
>=20
> '--------------------------------------
> Sub Ins=E9rerUnImage()
>=20
> Dim Image As Variant, Chemin As String
> Dim Filtre As String, Feuille As String, Plage As Range
>=20
> 'r=E9pertoire =E0 l'ouverture
> Chemin =3D "C:\Excel"
>=20
> 'Extensions des fichiers =E0 lister du r=E9pertoire
> Filtre =3D "*.Jpg;*.bmp;*.ico"
>=20
> 'O=F9 sera copier l'image :
> 'Nom de la feuille du classeur
> Feuille =3D "Feuil2"
>=20
> '=C9tendue de la plage qui sera recouverte par l'image
> 'Set Plage =3D Range("b5:D6")
=20
$$$ Set Plage =3D ActiveCell
>=20
> Image =3D SelectAFile(Chemin, Filtre)
> If Image <> "erann" Then
> 'Ins=E9rerImage Feuille, Range("b5:D6"), Image
Ins=E9rerImage Feuille, ActiveCell, Image

> End If
>=20
> End Sub
> '--------------------------------------
>=20
>=20
> Sub Ins=E9rerImage(Feuille As String, RgImage As Range,=20
NomImage As Variant)
> Dim Rg As Range
> Set Rg =3D Worksheets(Feuille).Range(RgImage.Address)
> With Rg
> Largeur =3D .Offset(, 1)(, .Columns.Count).Left -
.Left
> Hauteur =3D .Offset(.Rows.Count).Top - .Item
(1).Top
> Set Image =3D Worksheets(Feuille).Pictures.Insert
(NomImage)
> End With

$$$ Ht =3D Image.Width
$$$ Lar =3D Image.Height

> With Image
> .Left =3D Rg.Left
> .Top =3D Rg.Top
> 'Largeur de l'image
> Image.Width =3D Largeur
> 'Hauteur de l'image
> Image.Height =3D Hauteur
> 'Est-ce que l'image doit se d=E9placer avec les=20
cellules
> 'voici les 3 constantes possibles
> .Placement =3D xlFreeFloating 'or xlmove or=20
xlMoveAndSize
> 'Verrouill=E9 ou pas
> .Locked =3D True 'or False
> End With

$$$ ActiveCell.EntireColumn.ColumnWidth =3D Lar=20
$$$ ActiveCell.EntireRow.RowHeight =3D Ht=20

> Set Rg =3D Nothing
>=20
> End Sub

1 réponse

Avatar
Denis Michon
Bonjour Olivier,


C'est particulier comme demande. Je suppose que tu connais par avance la grandeur des images que tu veux insérer ...
sinon, il n'y a pas beaucoup de présentation de feuille d'excel qui tolèrerait l'insertion d'images de dimension toutes
différentes les unes des autres.

Ceci étant dit, Voici la problématique que soulève ton approche :

La propriété "Width" d'un objet "Range" permet d'obtenir avec précision la largeur de l'objet. L'unité de mesure est le
"point".
A = Range("A1").Width

La correspondance entre le point et le pixel
'1 Point = .75 pixel

Pour définir la largeur d'une colonne, on doit utiliser la propriété "ColumnWidth". Voici l'unité de mesure utilisé par
Excel : (Définition en provenance de l'aide d'excel) Range("A1").ColumnWidth = 10

ColumnWidth :
Une unité de largeur de colonne est égale à la largeur d'un caractère du style Normal. Dans le cas des polices
proportionnelles, la largeur du caractère 0 (zéro) est utilisée.

À la lecture de cette définition, tu vois toute suite le problème que cela cause... si on veut définir avec précision la
largeur d'une colonne. Personnellement, je ne connais pas de coefficient de conversion qui soit applicable à toutes les
figures (caractères) possibles. Tu dois par conséquent créer une bidouille qui va se contenter d'établir une
approximation de la largeur réelle de la colonne.


Voici un exemple de bidouille... il y a sûirement moyen de faire beaucoup mieux, mais je m'en voudrais de te priver de
ce plaisir ... à moins que quelqu'un d'autre connaisse une mesure de conversion fiable de "ColumnWidth" en pixel ou en
point.

'---------------------------------
Sub InsérerImage(Feuille As String, RgImage As Range, NomImage As Variant)
Dim Rg As Range, Rapport As Double
Application.ScreenUpdating = False

Set Rg = Worksheets(Feuille).Range(RgImage.Address)
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)

With Image
.Left = Rg.Left
.Top = Rg.Top
'Hauteur de l'image
For Each r In Rg.Rows
r.RowHeight = (Image.Height / Rg.Rows.Count)
Next

'La bidouille...
'*---------------------------------------
'Largeur de l'image
Rapport = 7
Do While Rg.Width < Image.Width
For Each c In Rg.Columns
c.ColumnWidth = (((Image.Width / Rg.Columns.Count)) / Rapport) * 1.25
Next
If Rg.Width < Image.Width Then
Rapport = Rapport - 0.002
End If
Loop
Do While Rg.Width > Image.Width
For Each c In Rg.Columns
c.ColumnWidth = (((Image.Width / Rg.Columns.Count)) / Rapport) * 1.25
Next
If Rg.Width > Image.Width Then
Rapport = Rapport + 0.002
End If
Loop
'*---------------------------------------
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing

End Sub
'---------------------------------



Salutations!






"Olivier" a écrit dans le message de
news:0de501c3a47c$e8fb7740$
Bonjour à tous !

En référence au message de Denis Michon"
....

Cette fonction est vraiment terrible ! Merci !

Mais j'essaie vainement d'apporter une petite modif, mais
cela ne fonctionne pas !
En fait je voudrais à la fin de la macro appliquer la
taille de l'image à la taille de la cellule, à savoir si
l'image fait 375 x 372 pixels je voudrais que ma cellule
soit redimensionnée avec ces valeurs.

Voir le code que j'ai rajouté ci dessous, marqué par $$$
(Les $$$ ne sont pas dans mon code c'est juste pour
repérer mes modifs ici !)

MERCI D'AVANCE !!!!

Olivier

----- Original Message -----
From: "Denis Michon"
Newsgroups: microsoft.public.fr.excel
Sent: Saturday, November 01, 2003 5:14 PM
Subject: Re: inserer image


Bonjour Christian,

'Un merci à Denis Pasquier (mpfe) pour l'api que j'ai
modifié pour ton problème.


Voici une façon de faire :

Tu appelles la procédure : Sub InsérerUnImage()

Tu prends soin de définir les variables suivantes selon
ton projet.

A ) Chemin
B ) Filtre
C ) Feuille
D ) Plage


Dans le haut d'un module standard : Déclaration de l'api
'-------------------
Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As
OPENFILENAME) As Long


Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Function SelectAFile(Chemin As String, Optional
Filtre As String = "*.*") As String

Dim OpenFile As OPENFILENAME, lReturn As Long, sFilter
As String

OpenFile.lStructSize = Len(OpenFile)
sFilter = "Tous les fichiers (" & Filtre & ")" & Chr
(0) & Filtre & Chr(0)

With OpenFile
.lpstrFilter = sFilter
.nFilterIndex = 1
.lpstrFile = String(257, 0)
.nMaxFile = Len(OpenFile.lpstrFile) - 1
.lpstrFileTitle = OpenFile.lpstrFile
.nMaxFileTitle = OpenFile.nMaxFile
.lpstrInitialDir = Chemin
.lpstrTitle = "Vos images"
.flags = 0
End With
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
SelectAFile = "erann"
Else
SelectAFile = Trim(Left(OpenFile.lpstrFile, _
InStr(1, OpenFile.lpstrFile, Chr(0)) - 1))
End If
End Function



'--------------------------------------
Sub InsérerUnImage()

Dim Image As Variant, Chemin As String
Dim Filtre As String, Feuille As String, Plage As Range

'répertoire à l'ouverture
Chemin = "C:Excel"

'Extensions des fichiers à lister du répertoire
Filtre = "*.Jpg;*.bmp;*.ico"

'Où sera copier l'image :
'Nom de la feuille du classeur
Feuille = "Feuil2"

'Étendue de la plage qui sera recouverte par l'image
'Set Plage = Range("b5:D6")


$$$ Set Plage = ActiveCell

Image = SelectAFile(Chemin, Filtre)
If Image <> "erann" Then
'InsérerImage Feuille, Range("b5:D6"), Image
InsérerImage Feuille, ActiveCell, Image


End If

End Sub
'--------------------------------------


Sub InsérerImage(Feuille As String, RgImage As Range,
NomImage As Variant)

Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left -
.Left

Hauteur = .Offset(.Rows.Count).Top - .Item
(1).Top

Set Image = Worksheets(Feuille).Pictures.Insert
(NomImage)

End With


$$$ Ht = Image.Width
$$$ Lar = Image.Height

With Image
.Left = Rg.Left
.Top = Rg.Top
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les
cellules

'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or
xlMoveAndSize

'Verrouillé ou pas
.Locked = True 'or False
End With


$$$ ActiveCell.EntireColumn.ColumnWidth = Lar
$$$ ActiveCell.EntireRow.RowHeight = Ht

Set Rg = Nothing

End Sub