Re : copier coller userform en tant que métafichier amélioré
Bonsoir à tous
Pierrot75
Si j'ai bien compris, peut_être que ce code de Brian Baulsom glané dans mes archives te sera utile
Code VB:
=====================================================================
'- VBA CODE TO SCREEN COPY A USERFORM AND SAVE AS A BITMAP FILE
'- 1. API Mimics 'Alt + PrintScreen' (Sendkeys method not work from a form.)
'- 2. Get next file name from folder eg.ScreenShot_001.bmp,ScreenShot_002.bmp
'- 3. Copy to MS Paint and save as bitmap - using SendKeys
'=====================================================================
'- Cannot declare API functions in a Userform ........
'- ..... so might as well put all code in a normal module
'- Brian Baulsom July 2008
'=====================================================================
'- API FOR KEY PRESSES
Public Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Const VK_KEYUP = &H2
Public Const VK_SNAPSHOT = &H2C
Public Const VK_MENU = &H12
'---------------------------------------------------------------------
'- FOLDER FOR SAVED PICTURES
Const MyScreenShotFolder As String = "F:\TEMP\"
'---------------------------------------------------------------------
'- MS PAINT
Const MSPaint As String = "C:\WINDOWS\system32\mspaint.exe"
Const Alt As String = "%" ' for SendKeys Alt key
'---------------------------------------------------------------------
'- BITMAP FILE
Dim BitmapFileName As String ' file name without "_00x.bmp" ending
Dim FullFileName As String ' full path
Dim RetVal ' Shell error return. Not used here.
'---------------------------------------------------------------------
'- GET NEXT FILE NAME (Uses FileSystemObject)
Dim FSO As Object
Dim FileNumber As Integer
Dim LastFileNumber As Integer
'-- end of declarations ----------------------------------------------
'=====================================================================
'- CODE TO OPEN USERFORM - Button in a worksheet
'=====================================================================
Sub Button1_Click()
UserForm1.Show
Unload UserForm1
End Sub
'---------------------------------------------------------------------
'=====================================================================
'- API PRINT SCREEN (COPY TO CLIPBOARD)
'- ** This code is called from the userform eg. button ***
'- Requires Key Up and Key Down code to mimic key presses
'=====================================================================
Sub PRINT_SCREEN()
'- API print screen
keybd_event VK_MENU, 0, 0, 0 ' Alt key down
DoEvents
keybd_event VK_SNAPSHOT, 0, 0, 0 ' PrintScreen key down
DoEvents
keybd_event VK_SNAPSHOT, 0, VK_KEYUP, 0 'Alt key up
DoEvents
keybd_event VK_MENU, 0, VK_KEYUP, 0 'PrintScreen key up
DoEvents
'------------------------------------------------------------------
SAVE_PICTURE ' subroutine
End Sub
'------------ eop -----------------------------------------------------
'=====================================================================
'- MSPAINT : PASTE PICTURE - SAVE AS BITMAP FILE
'=====================================================================
'- NB. Sendkeys requires 'Wait' statements to delay code while things
'- happen on screen.
'- These can be changed as required depending on computer speed
'- This routine can be used alone if there is something in the Clipboard
'- Not been able to get this to work with Paint Hidden or Minimised
'=====================================================================
Private Sub SAVE_PICTURE()
'-----------------------------------------------------------------
'- file name
BitmapFileName = "ScreenShot" ' completed by subroutine
'-----------------------------------------------------------------
GET_NEXT_FILENAME ' SUBROUTINE (can be omitted)
'-----------------------------------------------------------------
FullFileName = MyScreenShotFolder & BitmapFileName & ".bmp"
'-----------------------------------------------------------------
'- open Paint
RetVal = Shell(MSPaint, vbNormalFocus) ' normal screen
Application.StatusBar = " Open MS Paint"
Application.Wait Now + TimeValue("00:00:02") ' 2 seconds to open
'- paste ----------------------------------------------------------
Application.StatusBar = " Paste picture"
SendKeys Alt & "E", True ' edit
SendKeys "P", True 'paste
DoEvents
Application.Wait Now + TimeValue("00:00:01") ' wait 1 second
'- save file ------------------------------------------------------
Application.StatusBar = " Saving " & FullFileName
SendKeys Alt & "F" ' File menu
DoEvents
Application.Wait Now + TimeValue("00:00:01") ' wait 1 second
SendKeys "A", True ' Save As dialog
DoEvents
Application.Wait Now + TimeValue("00:00:01")
SendKeys FullFileName, True ' type file name
DoEvents
Application.Wait Now + TimeValue("00:00:02") ' wait 2 seconds
SendKeys Alt & "S", True ' Save
DoEvents
Application.Wait Now + TimeValue("00:00:03") ' 3 seconds to save
'- close ----------------------------------------------------------
Application.StatusBar = " Closing Paint"
SendKeys Alt & "{F4}", True
DoEvents
Application.StatusBar = False
MsgBox ("File Saved.")
End Sub
'-- eop ----------------------------------------------------------------
'=====================================================================
'- SUBROUTINE : GET NEXT FILE NAME -> BitMapFileName + "_xxx"
'- Called from Sub SAVE_PICTURE()
'=====================================================================
Private Sub GET_NEXT_FILENAME()
Dim f, f1, fc
Dim Fname As String
Dim F3 As String ' number
Dim Flen As Integer ' length
'-----------------------------------------------------------------
Set FSO = CreateObject("Scripting.FileSystemObject")
Set f = FSO.GetFolder(MyScreenShotFolder)
Set fc = f.Files
LastFileNumber = 0
'- length of file name = name + number + suffix
Flen = Len(BitmapFileName) + 4 + 4
'-----------------------------------------------------------------
'- LOOP FILES IN FOLDER
For Each f1 In fc
Fname = f1.Name
'---------------------------------------------------------
'- check valid file and number
F3 = Mid(Fname, Len(Fname) - 6, 3) ' number string
If InStr(1, Fname, BitmapFileName, vbTextCompare) <> 0 _
And IsNumeric(F3) And Len(Fname) = Flen Then
FileNumber = CInt(F3)
If FileNumber > LastFileNumber Then
LastFileNumber = FileNumber
End If
End If
'---------------------------------------------------------
Next
LastFileNumber = LastFileNumber + 1
'-----------------------------------------------------------------
'- Next file name
BitmapFileName = BitmapFileName & "_" & Format(LastFileNumber, "000")
End Sub
'-- eop --------------------------------------------------------------
