Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel Macro pour coller dans Paint

Macro pour coller dans Paint

6 réponses
Avatar
Ellimac
Bonjour,

Le bout de code suivant a fonctionn=E9 sous NT en XL 97 mais=20
ne fonctionne plus en XL 2003 sous XP :

Sub Paint()
Selection.Copy
Ret =3D Shell("C:\WINDOWS\system32\mspaint.exe", 1)
AppActivate Ret, True
Application.SendKeys "^v", True
End Sub

Cela ouvre bien Paint mais plantage pour activer Paint et=20
donc le coller ne s'effectue pas.=20
Il s'arr=EAte sur la ligne (erreur 5) : AppActivate Ret, True
et si je clique sur d=E9bogage et je poursuis l'ex=E9cution=20
cela fonctionne.

Camille
Signaler un problème avec ce contenu

6 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
Michel Pierron
Bonjour Ellimac;
Par défaut, la fonction Shell exécute les autres programmes de manière
asynchrone. Cela signifie qu'un programme lancé avec Shell peut ne pas
s'exécuter entièrement avant que les instructions suivant la fonction Shell
ne soient exécutées. Il faut don introduire une boucle jusqu'a ce que
l'application Paint soit disponible:

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
1: On Error Resume Next
AppActivate Ret, True
If Err Then On Error GoTo 0: GoTo 1
Application.SendKeys "^v", True
End Sub

MP

"Ellimac" a écrit dans le message de
news:151501c4fc72$0cb7cd20$
Bonjour,

Le bout de code suivant a fonctionné sous NT en XL 97 mais
ne fonctionne plus en XL 2003 sous XP :

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
AppActivate Ret, True
Application.SendKeys "^v", True
End Sub

Cela ouvre bien Paint mais plantage pour activer Paint et
donc le coller ne s'effectue pas.
Il s'arrête sur la ligne (erreur 5) : AppActivate Ret, True
et si je clique sur débogage et je poursuis l'exécution
cela fonctionne.

Camille
Avatar
Ellimac
Bonjour Michel,

Merci cela fonctionne mais quel temps pour que Paint soit
activé !!!
As-tu une idée de la différence de traitement entre Win NT
et XP ?
Y aurait-il une autre méthode pour copier mon bout de
tableau sous Paint ? L'objectif est de créer un fichier
image.

Camille

-----Message d'origine-----
Bonjour Ellimac;
Par défaut, la fonction Shell exécute les autres
programmes de manière

asynchrone. Cela signifie qu'un programme lancé avec
Shell peut ne pas

s'exécuter entièrement avant que les instructions suivant
la fonction Shell

ne soient exécutées. Il faut don introduire une boucle
jusqu'a ce que

l'application Paint soit disponible:

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
1: On Error Resume Next
AppActivate Ret, True
If Err Then On Error GoTo 0: GoTo 1
Application.SendKeys "^v", True
End Sub

MP

"Ellimac" a écrit
dans le message de

news:151501c4fc72$0cb7cd20$
Bonjour,

Le bout de code suivant a fonctionné sous NT en XL 97 mais
ne fonctionne plus en XL 2003 sous XP :

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
AppActivate Ret, True
Application.SendKeys "^v", True
End Sub

Cela ouvre bien Paint mais plantage pour activer Paint et
donc le coller ne s'effectue pas.
Il s'arrête sur la ligne (erreur 5) : AppActivate Ret,
True

et si je clique sur débogage et je poursuis l'exécution
cela fonctionne.

Camille

.



Avatar
Daniel.j
Bonjour,
¨Pour exporter une plage (A1:B10 par ex) directement en fichier image:

Sub exportgif()
Dim Plage As Range
Set Plage = Application.InputBox(Prompt:="Sélectionner votre zone: (Ex. A1:B10) ", _
Title:="Sélection de zone ", Default:="$A$1", Type:=8)
Application.ScreenUpdating = False
Workbooks.Add
Plage.CopyPicture
ActiveSheet.Paste
With ActiveSheet.ChartObjects.Add(0, 0, _
Selection.Width, Selection.Height).Chart
.Paste
.Export "C:ajeterTest.gif", "GIF"
End With
ActiveWorkbook.Close False
End Sub

--
Daniel
FAQ du Forum Microsoft Public Fr Excel
http://dj.joss.free.fr/faq.htm

"Ellimac" a écrit dans le message de news:
18bd01c4fc7b$4b616eb0$
Bonjour Michel,

Merci cela fonctionne mais quel temps pour que Paint soit
activé !!!
As-tu une idée de la différence de traitement entre Win NT
et XP ?
Y aurait-il une autre méthode pour copier mon bout de
tableau sous Paint ? L'objectif est de créer un fichier
image.

Camille

-----Message d'origine-----
Bonjour Ellimac;
Par défaut, la fonction Shell exécute les autres
programmes de manière

asynchrone. Cela signifie qu'un programme lancé avec
Shell peut ne pas

s'exécuter entièrement avant que les instructions suivant
la fonction Shell

ne soient exécutées. Il faut don introduire une boucle
jusqu'a ce que

l'application Paint soit disponible:

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
1: On Error Resume Next
AppActivate Ret, True
If Err Then On Error GoTo 0: GoTo 1
Application.SendKeys "^v", True
End Sub

MP

"Ellimac" a écrit
dans le message de

news:151501c4fc72$0cb7cd20$
Bonjour,

Le bout de code suivant a fonctionné sous NT en XL 97 mais
ne fonctionne plus en XL 2003 sous XP :

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
AppActivate Ret, True
Application.SendKeys "^v", True
End Sub

Cela ouvre bien Paint mais plantage pour activer Paint et
donc le coller ne s'effectue pas.
Il s'arrête sur la ligne (erreur 5) : AppActivate Ret,
True

et si je clique sur débogage et je poursuis l'exécution
cela fonctionne.

Camille

.



Avatar
Michel Pierron
Re Ellimac;
Une macro passe-partout; tu peux copier une plage de cellules, un graphique,
une image, enfin bref, ce que tu veux, l'image sera sauvée au format bmp à
l'endroit qu' il te suffit de préciser:
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

Sub MakeImgFile()
If TypeName(Selection) = "Range" Then
If Selection.Areas.Count > 1 Then
MsgBox " Multiple selections !", 48
Exit Sub
End If
End If
Selection.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, "c:Recup.bmp"
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard
End Sub

MP

"Ellimac" a écrit dans le message de
news:151501c4fc72$0cb7cd20$
Bonjour,

Le bout de code suivant a fonctionné sous NT en XL 97 mais
ne fonctionne plus en XL 2003 sous XP :

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
AppActivate Ret, True
Application.SendKeys "^v", True
End Sub

Cela ouvre bien Paint mais plantage pour activer Paint et
donc le coller ne s'effectue pas.
Il s'arrête sur la ligne (erreur 5) : AppActivate Ret, True
et si je clique sur débogage et je poursuis l'exécution
cela fonctionne.

Camille
Avatar
Ellimac
Bonjour,

Et merci beaucoup. Nickel ce qu'il me faut. J'avais bien
pensé au graphique avec une image mais butais
effectivement sur la notion de taille...
Encore merci

Camille

-----Message d'origine-----
Bonjour,
¨Pour exporter une plage (A1:B10 par ex) directement en
fichier image:


Sub exportgif()
Dim Plage As Range
Set Plage = Application.InputBox(Prompt:="Sélectionner
votre zone: (Ex. A1:B10) ", _

Title:="Sélection de zone ", Default:="$A$1", Type:=8)
Application.ScreenUpdating = False
Workbooks.Add
Plage.CopyPicture
ActiveSheet.Paste
With ActiveSheet.ChartObjects.Add(0, 0, _
Selection.Width, Selection.Height).Chart
..Paste
..Export "C:ajeterTest.gif", "GIF"
End With
ActiveWorkbook.Close False
End Sub

--
Daniel
FAQ du Forum Microsoft Public Fr Excel
http://dj.joss.free.fr/faq.htm

"Ellimac" a écrit
dans le message de news:

18bd01c4fc7b$4b616eb0$
Bonjour Michel,

Merci cela fonctionne mais quel temps pour que Paint soit
activé !!!
As-tu une idée de la différence de traitement entre Win NT
et XP ?
Y aurait-il une autre méthode pour copier mon bout de
tableau sous Paint ? L'objectif est de créer un fichier
image.

Camille

-----Message d'origine-----
Bonjour Ellimac;
Par défaut, la fonction Shell exécute les autres
programmes de manière

asynchrone. Cela signifie qu'un programme lancé avec
Shell peut ne pas

s'exécuter entièrement avant que les instructions suivant
la fonction Shell

ne soient exécutées. Il faut don introduire une boucle
jusqu'a ce que

l'application Paint soit disponible:

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
1: On Error Resume Next
AppActivate Ret, True
If Err Then On Error GoTo 0: GoTo 1
Application.SendKeys "^v", True
End Sub

MP

"Ellimac" a écrit
dans le message de

news:151501c4fc72$0cb7cd20$
Bonjour,

Le bout de code suivant a fonctionné sous NT en XL 97
mais


ne fonctionne plus en XL 2003 sous XP :

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
AppActivate Ret, True
Application.SendKeys "^v", True
End Sub

Cela ouvre bien Paint mais plantage pour activer Paint et
donc le coller ne s'effectue pas.
Il s'arrête sur la ligne (erreur 5) : AppActivate Ret,
True

et si je clique sur débogage et je poursuis l'exécution
cela fonctionne.

Camille

.




.




Avatar
Ellimac
Re Michel,

OK cela fonctionne, mais que d'instructions !!!
D'un penchant minimaliste je conserve ta réponse mais
penche plus pour la solution de Daniel.
Merci encore

Camille

-----Message d'origine-----
Re Ellimac;
Une macro passe-partout; tu peux copier une plage de
cellules, un graphique,

une image, enfin bref, ce que tu veux, l'image sera
sauvée au format bmp à

l'endroit qu' il te suffit de préciser:
Option Explicit
Private Declare Function CloseClipboard Lib "user32" ()
As Long

Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" ()
As Long

Private Declare Function IsClipboardFormatAvailable
Lib "user32" _

(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal
handle& _

, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect
Lib "olepro32" _

(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn
As Long _

, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

Sub MakeImgFile()
If TypeName(Selection) = "Range" Then
If Selection.Areas.Count > 1 Then
MsgBox " Multiple selections !", 48
Exit Sub
End If
End If
Selection.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-
00AA00300CAB}"

Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As
Long

Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
..cbSize = Len(PCT)
..picType = 1
..hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, "c:Recup.bmp"
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard
End Sub

MP

"Ellimac" a écrit
dans le message de

news:151501c4fc72$0cb7cd20$
Bonjour,

Le bout de code suivant a fonctionné sous NT en XL 97 mais
ne fonctionne plus en XL 2003 sous XP :

Sub Paint()
Selection.Copy
Ret = Shell("C:WINDOWSsystem32mspaint.exe", 1)
AppActivate Ret, True
Application.SendKeys "^v", True
End Sub

Cela ouvre bien Paint mais plantage pour activer Paint et
donc le coller ne s'effectue pas.
Il s'arrête sur la ligne (erreur 5) : AppActivate Ret,
True

et si je clique sur débogage et je poursuis l'exécution
cela fonctionne.

Camille

.