problème arrière plan excel vba

Version imprimable

02/12/2007, 17h12
xav30

problème arrière plan excel vba

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?
02/12/2007, 17h41
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?

@+

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:

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

pb redimentionnement

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:

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.

03/12/2007, 01h21
fred65200

bonsoir,
Je n'ai que quatre références de cochées et ça fonctionne
http://www.fcbat.com/temp/reference.JPG
EDIT essaie de cocher la référence WIA... mais à priori pas besoin ici
Tiens nous au courant

cordialement
03/12/2007, 11h09
ouskel'n'or

Tu es sur quel version d'Excel ?
03/12/2007, 14h59
xav30

pb dimentionnement image

Salut à tous et merci de m'aider!!!
Ma version d'excel est la version 2002.
Fred j'ai essayé de faire ce que tu ma dit mais ça marche pas, je sais pas pourquoi.
Si vous avez d'autres idées je suis à l'écoute.
Merci encore!
Xav30.
03/12/2007, 16h38
fred65200

bonjour,

a priori WIA n'est pris en charge qu' à partir d'Xp. Es tu sur XP ou supérieur?

Cordialement
03/12/2007, 18h31
xav30

yeah!!!

Salut Fred et ouskel'n'dor!!!
Je tiens à vous remercier d'avoir réfléchi sur mon problème!
J'ai trouvé la solution comme un grand (pour une fois...)!
En fait il fallait cocher dans les références:
DirectX8 for Visual Basic Type Library
et ça marche!!!
C'est beau la science des fois quand même!!
Merci encore à vous deux et spécialement à Fred qui ne me laisse jamais en rade!
Merci encore!
Xav 30.
Ps:Je clique sur RESOLU!
03/12/2007, 22h03
xav30

ERRATUM

En fait je me suis planté ça marche toujours pas, en fait je n'ai pas relancé Excel alors que l'appel du programme se trouve dans le Workbook open!
Quel idiot je suis!!!
En fait me revoilà dans la panade, quelqu'un pourrait-t-il m'aider?
Je vais relancer une discution à ce sujet parceque comme j'ai cliqué sur résolu, je suis pas sûr qu'on me réponde...
Merci à qui voudra bien m'aider!
xav30.
03/12/2007, 22h05
xav30

problème de redimentionnement

Désolé je savais pas qu'on pouvait décocher résolu!!!
Merci de votre aide!!
Xav'30
03/12/2007, 22h34
fred65200

bonsoir xav30,

je ne comprenais pas trop le lien avec DirectX8...

Tu es sur XP ou Vista?

Est ce que tu as la dll "C:\Windows\System32\wiaaut.dll" sur ton poste?

EDIT Si tu ne la trouves pas et que tu es sur XP SP1 ou supérieur tu la trouveras ici.
- Télécharge le dossier WIAAutSDK.zip.
- Extraits les fichiers
- Copie les fichiers wiaaut.chm et wiaaut.chi dans C:\Windows\Help\
- Copie wiaaut.dll dans C:\Windows\System32\
- Dans la fenêtre Exécuter (touche Windows + R), saisies RegSvr32 WIAAut.dll
- Clique sur OK --> Message de réussite
- Lance ta macro et tiens nous au courant.

Par contre si les autres postes n'ont pas cette dll, je te souhaite bien du courage :D

EDIT2

Citation:

je n'ai pas relancé Excel alors que l'appel du programme se trouve dans le Workbook open!

Tu peux lancer directement la macro AjusterImage sur VBE pour tester ou mettre un bouton sur ta feuille et lui affecter cette même macro.

cordialement
04/12/2007, 00h32
xav30

merci

Merci beaucoup fred!!! T'es vraiment trop balèze, ça marche!!!
Merci beaucoup!
Xav30