Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_SNAPSHOT = 44
Const VK_LMENU = 164
Const KEYEVENTF_KEYUP = 2
Const KEYEVENTF_EXTENDEDKEY = 1
Private Declare Function GetWindowLongA Lib "user32" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub Image1_Click()
Dim pdfName As String
a = Sheets("ACCUEIL").Range("AO1").Value 'Variable largeur d'impression.....
Application.ScreenUpdating = False '...............................
keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
DoEvents
ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.2)
.RightMargin = Application.InchesToPoints(0.2)
.TopMargin = Application.InchesToPoints(0.236)
.BottomMargin = Application.InchesToPoints(0.236)
.Orientation = xlLandscape
.CenterHorizontally = True
.CenterVertically = True
End With
ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
'Redimentionnement de l'image................
With ActiveSheet.Shapes("Picture 1")
.Height = 270
.Width = a
End With
pdfName = ActiveWorkbook.Path & "\" & Label16.Caption & "_" & ComboBox1.Value & "_" & ComboBox2.Value & ".pdf"
'Debug.Print pdfName
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=pdfName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.DisplayAlerts = False '.............................
Worksheets(Worksheets.Count).Delete
'Application.SendKeys "{ENTER}"
Unload Me
Application.DisplayAlerts = True '.............................
Application.ScreenUpdating = True '.............................
Sheets("ACCUEIL").Activate
End Sub
,
