1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
|
Sub CrerImageAvecJPG()
Dim NumPrel, Description, REP As String
Dim Repertoire As FileDialog
Dim Ochart As ChartObject
Dim ZoneImpAvecImg As Range
Dim Sh_temp As Worksheet
Dim Ch_temp As Chart
Dim PicTemp As Picture
NumPrel = Range("NumPrel").Value
Description = Range("Description").Value
Application.ScreenUpdating = False
Calculate
DoEvents
ActiveWorkbook.Save 'enregistre le classeur
ActiveSheet.Unprotect Password:="zweco"
'contrôles de la saisie complète des données
X = "YES"
If Range("Description").Value = "" Then
X = "NO"
MsgBox "Vous n'avez pas saisi de description de l'échantillon"
End If
If Range("NumPrel").Value = "" Then
X = "NO"
MsgBox "Vous n'avez pas saisi le numéro du prélèvement"
End If
If Range("Labo").Value = "" Then
X = "NO"
MsgBox "Vous n'avez pas saisi la nom du labo"
End If
'Choix du répeertoire où enregistrer le document
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker) 'selection du répertoire
Repertoire.Show
If Repertoire.SelectedItems.Count > 0 Then
Else
MsgBox "Aucun Répertoire Sélectionné": ActiveSheet.Protect Password:="zweco", DrawingObjects:=False, Contents:=True, AllowFormattingCells:=True 'protège la feuille
Exit Sub
End If
REP = Repertoire.SelectedItems(1)
ChDir (REP)
'Impression avec image
Application.ScreenUpdating = False
Set ZoneImpAvecImg = ActiveSheet.Range("ZoneImpAvecImg")
Set Sh_temp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=Sh_temp.Name
Set Ch_temp = ActiveChart
ZoneImpAvecImg.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Ch_temp.Paste
Set PicTemp = Selection
With Ch_temp.Parent
.Width = 2800
.Height = 600
End With
Application.DisplayAlerts = False
ActiveSheet.PageSetup.PrintArea = Range("ZoneImpAvecImg")
Ch_temp.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Ech n° " & NumPrel & " - " & Description, Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Sh_temp.Delete
Application.DisplayAlerts = True
Fin:
End Sub |
Partager