Discussion :

[xav30]

Bonjour à tous!!! (Bonjour à Fred parce que c'est toujours lui qui me répond et qui résoud mes problèmes!)
Voici mon problème:
J'ai une image en arrière plan sur une feuille Excel qui fait la taille de mon écran (elle se répète sur toute la feuille excel). Cependant le problème est que lorsque j'ouvre cette feuille avec un autre PC que le mien (de taille d'écran différente), l'image ne s'adapte pas à la taille de l'écran et c'est pas très beau!
Comment faire pour adapter mon image à une taille d'écran quelconque?
Une âme charitable (comme Fred) pourrait me venir en aide s'il vous plaît?

[fred65200]

Bonjour xav30

pour le tag Resolu, je parlais de ce post

Comment insères tu ton image d'arrière plan, par macro ou manuellement?

@+

[fred65200]

bonjour xav30

Je n'ai trouvé qu'une solution qui consiste à transporter ton image de fond dans le dossier où est ton classeur.
À l'ouverture du classeur, il s'affiche l'image de fond redimensionnées par rapport à la résolution d'écran.

cordialement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Option Explicit
'pour l'obtention de la resolution d'écran en pixels
Private Declare Function GetDC Lib "user32.dll" ( _
  ByVal hwnd&) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
  ByVal hwnd&, ByVal hDC&) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hDC&, ByVal nIndex&) As Long
 
''------------------------------------------------------
''Dans le module de code ThisWorkbook
''------------------------------------------------------
'Option Explicit
'
'Private Sub Workbook_Open()
'AjusterImage
'End Sub
''------------------------------------------------------
''Fin module de code ThisWorkbook
''------------------------------------------------------
Sub AjusterImage()
'D'après un excellent tutoriel de SilkyRoad
'http://silkyroad.developpez.com/VBA/WindowsImageAcquisition/
 
   Dim Img As Object 'WIA.ImageFile
   Dim IP As Object 'WIA.ImageProcess
   Dim Ext As String
   Dim monImage As String
   Dim ImageFond As String
   Dim CvtPtPixel As Single
 
  'Ton image de fond doit être dans le même dossier que ton classeur
  monImage = ThisWorkbook.Path & Application.PathSeparator & "monImage.jpg" ' A adapter
 
   'conversion des points en pixel
   CvtPtPixel = 0.75
   Ext = InStr(1, StrReverse(monImage), ".", vbTextCompare)
   ImageFond = Left(monImage, Len(monImage) - Ext) & "-Fond" & Right(monImage, Ext)
 
   ' suppression de l'image si elle existe
   On Error Resume Next
      Kill ImageFond
   On Error GoTo 0
 
   'Création conteneur pour l'image à manipuler
   Set Img = CreateObject("WIA.ImageFile")
   'Création du gestionnaire de filtre
   Set IP = CreateObject("WIA.ImageProcess")
   'Chargement de l'image dans le conteneur
   Img.LoadFile monImage
   'Ajoute le filtre pour redimensionner l'image (Scale)
   IP.Filters.Add IP.FilterInfos("Scale").FilterID
   'Définit la largeur maxi pour le redimensionnement
   IP.Filters(1).Properties("MaximumWidth") = ResolEcran(0) * CvtPtPixel
   'Définit la hauteur maxi pour le redimensionnement
   IP.Filters(1).Properties("MaximumHeight") = ResolEcran(1) * CvtPtPixel
'remarque :
'Les proportions sont conservées. Le filtre prend en compte
'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
'Application du filtre à l'image
   Set Img = IP.Apply(Img)
   'Enregistre l'image redimensionnée
   Img.SaveFile ImageFond
'mise en place de l'arrière plan
ActiveSheet.SetBackgroundPicture Filename:=""
ActiveSheet.SetBackgroundPicture Filename:=ImageFond
Set IP = Nothing
Set Img = Nothing
End Sub
 
Function ResolEcran(item As Byte) As Variant
Dim lDC&
 Static maResolution
If Not IsArray(maResolution) Then
  ReDim maResolution(1) As Long
  lDC = GetDC(0)                               '    -->  renvoie du contexte d'affichage de l'écran
  maResolution(0) = GetDeviceCaps(lDC, 8&)      '  -->   largeur de l'écran en pixels
  maResolution(1) = GetDeviceCaps(lDC, 10&)     '  -->   hauteur de l'écran en pixels
  lDC = ReleaseDC(0, lDC)
End If
ResolEcran = maResolution(item)
End Function

[xav30]

Salut fred!!
Merci encore de m'avoir répondu, c'est sympa!
Bon, j'ai essayé ton code mais j'ai un problème, il y a un message d'erreur qui apparaît: "un composant active x ne peut créer d'objet", voici l'endroit où ça buggue:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Option Explicit
'pour l'obtention de la resolution d'écran en pixels
Private Declare Function GetDC Lib "user32.dll" ( _
  ByVal hwnd&) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
  ByVal hwnd&, ByVal hDC&) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hDC&, ByVal nIndex&) As Long
 
Sub AjusterImage()
'D'après un excellent tutoriel de SilkyRoad
'http://silkyroad.developpez.com/VBA/WindowsImageAcquisition/
 
   Dim Img As Object 'WIA.ImageFile
   Dim IP As Object 'WIA.ImageProcess
   Dim Ext As String
   Dim monImage As String
   Dim ImageFond As String
   Dim CvtPtPixel As Single
 
  'Ton image de fond doit être dans le même dossier que ton classeur
  monImage = ThisWorkbook.path & Application.PathSeparator & "monImage.jpg" ' A adapter
 
   'conversion des points en pixel
   CvtPtPixel = 0.75
   Ext = InStr(1, StrReverse(monImage), ".", vbTextCompare)
   ImageFond = Left(monImage, Len(monImage) - Ext) & "-Fond" & Right(monImage, Ext)
 
   ' suppression de l'image si elle existe
   On Error Resume Next
      Kill ImageFond
   On Error GoTo 0
 
   'Création conteneur pour l'image à manipuler
   Set Img = CreateObject("WIA.ImageFile")   CA BUGGUE SUR CETTE LIGNE
   'Création du gestionnaire de filtre
   Set IP = CreateObject("WIA.ImageProcess")
   'Chargement de l'image dans le conteneur
   Img.LoadFile monImage
   'Ajoute le filtre pour redimensionner l'image (Scale)
   IP.Filters.Add IP.FilterInfos("Scale").FilterID
   'Définit la largeur maxi pour le redimensionnement
   IP.Filters(1).Properties("MaximumWidth") = ResolEcran(0) * CvtPtPixel
   'Définit la hauteur maxi pour le redimensionnement
   IP.Filters(1).Properties("MaximumHeight") = ResolEcran(1) * CvtPtPixel
'remarque :
'Les proportions sont conservées. Le filtre prend en compte
'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
'Application du filtre à l'image
   Set Img = IP.Apply(Img)
   'Enregistre l'image redimensionnée
   Img.SaveFile ImageFond
'mise en place de l'arrière plan
ActiveSheet.SetBackgroundPicture Filename:=""
ActiveSheet.SetBackgroundPicture Filename:=ImageFond
Set IP = Nothing
Set Img = Nothing
End Sub
 
Function ResolEcran(item As Byte) As Variant
Dim lDC&
 Static maResolution
If Not IsArray(maResolution) Then
  ReDim maResolution(1) As Long
  lDC = GetDC(0)                               '    -->  renvoie du contexte d'affichage de l'écran
  maResolution(0) = GetDeviceCaps(lDC, 8&)      '  -->   largeur de l'écran en pixels
  maResolution(1) = GetDeviceCaps(lDC, 10&)     '  -->   hauteur de l'écran en pixels
  lDC = ReleaseDC(0, lDC)
End If
ResolEcran = maResolution(item)
End Function

J'ai essayé d'activer dans les références : Microsoft ActiveX Data Objects 2.7 Library mais sans succès...
Voilà merci de me venir encore en aide!
Xav30.

[fred65200]

bonsoir,
Je n'ai que quatre références de cochées et ça fonctionne

EDIT essaie de cocher la référence WIA... mais à priori pas besoin ici
Tiens nous au courant

cordialement

[ouskel'n'or]

Tu es sur quel version d'Excel ?