XL 2013 Coller une capture d'ecran avec un code VBA dans excel

[Rabeto]

Bonjour,

Qui peut m'aider à résoudre ce mystère svp,
Cela fait 2 jours que je cherche sur le forums mais aucune réponse ne correspond à mes attentes.

" Je souhaite coller une capture d'écran dans excel en utilisant un macro "
La capture ne se fait pas par ALT+Imprécran mais via " Outils capture "

merci d'avance,

 

[Roland_M]

Bonjour,

c'est simple, on suppose que tu as fait une copie d'écran qui est supposée être placée dans le presse-papier !
il suffit de ce code que tu peux exécuter en faisant F5
Sub XXX
Range("A1").Select: ActiveSheet.Paste
End Sub

 

[Rabeto]

Merci Rolland_M

hhhhmmm, ca marche bien, mais sauf que si il n'y a pas de capture, cela fait erreur
j'en profite pour poser 2 petites questions,
- avec le même macro, je souhaite effacer d'abord la capture existante avant de coller une autre
- je souhaite joindre cette image dans un mail outlook,
Voici le code que j’utilise pour éditer le mail outlook :

Dim OutApp As Object
Dim OutMail As Object
Dim strto As String
Dim strsub As String, strbody As String

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

strsub = Range("C1").Value
strbody = "Bonjour," & "<br>" & "<br>" & Range("H1")

With OutMail
.Display
.CC = Range("I1")
.Subject = strsub
.HTMLBody = strbody & .HTMLBody
End With

 

[Roland_M]

re

Sub XXX()
Dim Obj As Shape
'efface image de la feuil.active !
For Each Obj In ActiveSheet.Shapes: Obj.Delete: Next
'colle nouvelle image
on error resume next
ActiveSheet.Paste
End Sub

quand à coller l'image, je n'ai pas outlook, mais on peut joindre la feuille contenant cette image !
là je n'aurais pas le temps je dois partir !

 

[Rabeto]

ok, je vais essayer de me débrouiller autrement alors,
ouppsss, en activant la macro, cela a effacé mes boutons,

Merci quand même Roland_M, cela va me servir de piste

 

[Roland_M]

re

reprends ceci avec test du type !

Sub XXX()
Dim Obj As Shape
'efface l'image de la feuil.active !
For Each Obj In ActiveSheet.Shapes
If Obj.Type = 13 Then Obj.Delete
Next
'colle nouvelle image
On Error Resume Next
ActiveSheet.Paste
End Sub

code exemple pour outlook (perso pas testé)

Public Sub EnvoiMailOutlookAvecFichJoint()
AdresDestinMail$ = "" 'destinataire
AdresMailCC$ = "" 'adres en copie
AdresMailBCC$ = "" 'adres en copie invisible
Sujet$ = "" 'objet du mail
Message$ = "" 'message
Chemin$ = "" 'dossier complet avec le fichier
EnvoiChemFich$ = FLoadCheminFichier$(Chemin$) 'nom complet pour l'envoi
If EnvoiChemFich$ = "" Then MsgBox "Aucun fichier!?", vbExclamation, "envoi": Exit Sub 'quitte
 On Error GoTo ErreurNET ' ENVOI
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
 With OutMail
  .To = AdresDestinMail$
  .CC = AdresMailCC$
  .BCC = AdresMailBCC$
  .Subject = Sujet$
  .Body = Message$
  .Attachments.Add EnvoiChemFich$
  '.Save '< svg email avant l'envoi
  '.Send '<<<<<<<< Pour envoyer directement
  .Display '<<<<<< Pour voir le mail avant envoi
  '^^^^^^^ après .Display pour confirmation auto > SendKeys "^{ENTER}"
End With
' fin
Set OutApp = Nothing: Set OutMail = Nothing
On Error GoTo 0: Err.Clear
Exit Sub
ErreurNET:  'sous prog erreur
Msg$ = "Erreur " & Err.Source & "  No " & Err.Number & vbLf & vbLf & Err.Description
T$ = "Envoi Mail: Problème de connexion !?"
MsgBox Msg$, vbCritical, T$, Err.HelpFile, Err.HelpContext
On Error GoTo 0: Err.Clear
End Sub



Private Sub EnvoiMailOutlookAvecFeuilJointe()
Dim OutApp As Object, OutMail As Object, NewB As Workbook
'---- variables nécessaire -------------
NomDuClasseur$ = "NomDuFichierJoint.xls" ' avec son extension
NomDeLaFeuille$ = "Feuil1"
AdresDestinMail$ = "nom@site.fr"
AdresMailCC$ = "nom@site.fr"
AdresMailBCC$ = "nom@site.fr"
Sujet$ = ""
Message$ = ""
'---------------------------------------

' Copie la feuille (ce qui cré un nouveau classeur qui devient actif)
CheminFichier$ = ThisWorkbook.Path & "\" & NomDuClasseur$ 'ajoute le chemin
Sheets(NomDeLaFeuille$).Copy
Set NewB = ActiveWorkbook
ActiveWorkbook.SaveAs CheminFichier$
On Error GoTo ErreurNET ' ENVOI
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
 .To = AdresDestinMail$
 .CC = AdresMailCC$
 .BCC = AdresMailBCC$
 .Subject = Sujet$
 .Body = Message$
 .Attachments.Add NewB.FullName
 '.Save '< svg email avant l'envoi
 '.Send '<<<<<<<< Pour envoyer directement
 .Display '<<<<<< Pour voir le mail avant envoi
 '^^^^^^^ après .Display pour confirmation auto > SendKeys "^{ENTER}"
End With
' close le classeur et le supprime du disque
ActiveWorkbook.Close
Kill CheminFichier$
' fin
Set OutApp = Nothing: Set OutMail = Nothing: Set NewB = Nothing
On Error GoTo 0: Err.Clear: Exit Sub
ErreurNET: 'sous prog erreur
Msg$ = "Erreur " & Err.Source & "  No " & Err.Number & vbLf & vbLf & Err.Description
T$ = "Envoi Mail: Problème de connexion !?"
MsgBox Msg$, vbCritical, T$, Err.HelpFile, Err.HelpContext
On Error GoTo 0: Err.Clear
End Sub

 

[dysorthographie]

Bonsoir,
Tu veux exécuter un imprim écran et l'inseré dans Excel pour un envoi par mail ? C'est bien cela ?

Cet imprim écran c'est ton fichier Excel qui est à l'écran ?

Je comprends pas bien!

https://www.excel-downloads.com/threads/envoi-plage-dans-corps-dun-mail.20040231/#post-20287617

 

[Rabeto]

Bonsoir,

Pour la première question c'est Oui
( mais je ne veux pas imprimer le fichier Excel mais autres choses qui peut se trouver sur mon bureau )
ça a bien été résolu,

Là ce que je souhaite c'est de pouvoir envoyer cette capture que j'ai mis sur excel par mail. (Outlook)

Code que j'ai utilisé pour la capture

Sub capture()
Application.ScreenUpdating = False
Dim s As Shape
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("Q1:W24")) Is Nothing Then
s.Delete
End If
Next s
Range("Q1").Select
Application.ScreenUpdating = True
Range("Q1").Select: ActiveSheet.Paste

End Sub

Code que j'utilise pour envoyer un mail via Outlook

Sub Mail ()

Dim OutApp As Object
Dim OutMail As Object
Dim strto As String
Dim strsub As String, strbody As String

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

strsub = Range("C1").Value
strbody = "Bonjour," & "<br>" & "<br>" & Range("H1")

With OutMail
.Display
.CC = Range("I1")
.Subject = strsub
.HTMLBody = strbody & .HTMLBody
End With

End Sub

Donc je veux fusionner les 2 Étapes en insérant la capture dans le corps de mon mail

" Voici un fichier qui peut servir d'exemple "

 

[Rabeto]

Quelqu'un peut m'aider svp, merci d'avance

 

[Roland_M]

Bonjour,

voir essai ce fichier (pré-rempli)
si problème voir côté vb si cette Référence est cochée !?
Microsoft CDO for windows 2000 library

pour cela dans la barre en haut Outils puis dans la liste Références ...

 

[Rabeto]

Merci Roland_M, j'ai essayé les codes que vous m'avez proposé avant mais chaque fois j'ai une erreur que je ne comprends pas,
je vais essayer de voir la dernière proposition

 

[Roland_M]

bonjour,

as-tu regardé côté vb si cette Référence est cochée ?
Microsoft CDO for windows 2000 library

 

[Rabeto]

Bonjour,

Oui, c'est bien coché