USF to JPG

[systmd]

Bonjour à tous

je cherche la manière d'enregistrer le résultat de la capture de l'UserForm dans un fichier JPG ou BMP

Merci d'avance

 

[Softmama]

Re : USF to JPG

Bonjour systmd,

Bon, j'ai un peu bricolé, mais je crois que c'est ce que tu souhaites obtenir :

Private Sub CommandButton2_Click()
    Me.Repaint
    keybd_event vbKeySnapshot, 1, 0&, 0&
    With ActiveSheet.ChartObjects.Add(0, 0, me.Width, me.Height).Chart
      .Paste
      .Export ThisWorkbook.Path & "\" & "Toto.jpg", "JPG"
    End With
    ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
End Sub

A noter, que je donne le nom Toto.jpg au fichier. Tu peux lui donner le nom que tu souhaites (passer une variable comme nom par exemple). L'extension .bmp s'obtient par la même commande :
.Export ThisWorkbook.Path & "\" & "Toto.bmp", "BMP"

EDIT: Simplification de la macro.

 

[Softmama]

Re : USF to JPG

Re,

A toutes fins utiles, pour exporter une copie d'écran d'un plage de cellules (au lieu d'un USF) vers un fichier .JPG, on peut utiliser une macro très semblable :

Sub PhotoPlage()
Dim Plage As Range
    Set Plage = Range("A1:F12") 'Adapter
    Plage.CopyPicture
    With ActiveSheet.ChartObjects.Add(0, 0, Plage.Width, Plage.Height).Chart
      .Paste
      .Export ThisWorkbook.Path & "\" & "Toto.jpg", "JPG"
    End With
    ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
End Sub

 

[systmd]

Re : USF to JPG

Bonjour Softmama,

Merci de t'être penché sur le problème.
La solution que tu me propose ma va, mais j'aurais voulu ne pas passer par un feuille, mais plutôt le faire directement comme la fonction SavePicture en VB.
Je vais adopter ta solution en attendant .

 

[Softmama]

Re : USF to JPG

Bonjour,

Je ne comprends pas ce que tu veux dire par là ?

 

[systmd]

Re : USF to JPG

Re
en clair je fait

Me.Repaint
keybd_event vbKeySnapshot, 1, 0&, 0&
Dovents 'Pour laisser le temps que la copie se fasse

Puis sauvegarde du presse papier directement en "Toto.jpg"
du style
SavePicture (Contenu du presse papier),ThisWorkbook.Path & "\" & "Toto.jpg"

 

[systmd]

Re : USF to JPG

Re, En fait je cherche à faire la même chose que le code ci-dessous (VB6) en VBA

Private Sub Command1_Click()
Dim objPic As IPictureDisp

If Clipboard.GetFormat(vbCFBitmap) Then
Set objPic = Clipboard.GetData(vbCFBitmap)
SavePicture objPic, App.Path & "\toto.bmp"
End If
End Sub

 

[Softmama]

Re : USF to JPG

Re,

Je ne sais pas si y a pas plus simple, mais bon... Vu que t'as l'air d'apprécier les API, tu vas être servi. (Adaptation d'un bout de code glané sur internet) :

Dans un module standard :

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

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

Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Public Declare Function EmptyClipboard& Lib "user32" ()
Public Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Public Declare Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Public Declare Function CloseClipboard& Lib "user32" ()
Public Declare Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Public Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long

Dans le Module de ton USF :

Private Sub CommandButton2_Click()
Dim hCopy&
Dim iPic As IPicture
Dim tIID As GUID
Dim tPICTDEST As PICTDESC
Dim Ret As Long
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
 Me.Repaint
 keybd_event vbKeySnapshot, 1, 0&, 0&
 TT = 0.5 + Timer: Do While Timer < TT: DoEvents: Loop
 
' A adapter ////////////////
Chemin = ThisWorkbook.Path & "\"
Fichier = "Toto2.jpg"  ' Tu peux mettre Toto3.bmp, ça fonctionne aussi (ou toto4.gif)
'///////////////////////////

OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
  .cbSize = Len(tPICTDEST)
  .picType = 1
  .hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)

SavePicture iPic, Chemin & Fichier
Set iPic = Nothing
End Sub

Vois le fichier joint...

 

[systmd]

Re : USF to JPG

Re,

Merci je teste celà de suite .
En attendant j'ai trouvé une solution, moi aussi, en utilisant la méthode de Stephen Bullen "Paste Picture".
Pour ma part ce fil est résolu et te remercie à nouveau pour ton investissement à mon égard.
A bientôt sur la toile