Discussion :

[EoWinn]

Bonjour a tous,
j'ai un petit souci je vous explique du mieux possible ci-dessous :

j'ai un userform avec tout plein de jolis boutons et autre joyeusetés du genre.

je sais imprimer tout ce joli monde par un beau userform.printform mais j'aimerais ajouter un beau bouton pour mailler de beau formulaire.

et là ca va plus bien sur.

je pourrais passer par un pdf et le joindre a un mail pas, de souci pour le mail mais comment passer ce foutu userform en pdf. Je pourrais bien sur récupérer l'imprimante par défaut Windows et forcer l'imprimante pdf mais la aussi attention le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 imprimante = Application.ActivePrinter
 Application.ActivePrinter = "Adobe PDF"
 userform.printform
 Application.ActivePrinter = imprimante

fonctionne pas enfin fonctionne sur l'imprimante excel mais pas sur la Windows ce qui revient au même puisque pas de fichier pdf

reste la solution de changer l'imprimante par défaut Windows mais dieu quel code pour si peut de chose

donc si quelqu'un de vous a sous le coude un code ou une idée lumineuse je suis preneur car je tourne en rond

[Oliv-]

Bonsoir,

Essaye comme cela

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
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
 
'Adapted from Kenneth Hobs
'at http://www.ozgrid.com/forum/showthread.php?t=157677
 
Private Sub CommandButton1_Click()
'---------------------------------------------------------------------------------------
' Procedure : CommandButton1_Click
' Author    : OLiv
' Date      : 28/12/2015
' Purpose   : Copy d'un userform vers outlook
'---------------------------------------------------------------------------------------
'
 
'change to your button name
    Dim pdfName As String
    Dim newWS As Worksheet
 
    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    'Otherwise, all of screen would be pasted as if PrtScn rather than Alt+PrtScn was used for the copy.
 
    Const olMailItem = 0
    'Open a new mail item
    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Dim outMail As Object
    Set outMail = outlookApp.CreateItem(olMailItem)
 
    'Get its Word editor
    outMail.Display
    Dim wordDoc As Object
    Set wordDoc = outMail.GetInspector.WordEditor
 
    'To paste as picture
    wordDoc.Range.PasteAndFormat 1 'wdChartPicture
    Unload Me
End Sub

[kiki29]

Salut, code de l'UserForm

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Explicit
 
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 Sub CommandButton1_Click()
Dim sNomPDF As String
 
    Application.ScreenUpdating = False
 
    PrintScreen
    DoEvents
 
    ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
 
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.197)
        .RightMargin = Application.InchesToPoints(0.197)
        .TopMargin = Application.InchesToPoints(0.197)
        .BottomMargin = Application.InchesToPoints(0.197)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
    End With
 
    ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
    sNomPDF = ActiveWorkbook.Path & "\" & "UserForm.pdf"
 
    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sNomPDF, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=False, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
 
    Application.DisplayAlerts = False
    Worksheets(Worksheets.Count).Delete
    Unload Me
    Application.DisplayAlerts = True
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub PrintScreen()
    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
End Sub

[EoWinn]

bien après test, vos 2 solutions passe par un print-screen et donc il me manque des éléments de mon beau userform

que j'ai par le printform

j'ai la journée pour voir le code de changement d'imprimante par défaut

ça va être une usine a gaz juste pour cette partie là

si une autre idée est dispo je suis quand même toujours preneur

joyeux noël a tous

[Oliv-]

Voici un code très simple et efficace pour changer l'imprimante par défaut

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Private Declare Function SetDefaultPrinterAPI Lib "winspool.drv" Alias "SetDefaultPrinterA" (ByVal pszPrinter As String) As Long
 
 
sub change ()
SetDefaultPrinterAPI  "nom imprimante"
end sub

[EoWinn]

voila ou j'en suis

mis ca dans un module

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 Declare Function GetPrivateProfileString _
Lib "Kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName _
As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize _
As Long, ByVal lpFileName As String) As Long
 
 Declare Function GetWindowsDirectory _
Lib "Kernel32" Alias "GetWindowsDirectoryA" _
  (ByVal lpBuffer As String, ByVal nSize _
  As Long) As Long
 
 Declare Function SendMessage Lib _
"user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Integer, ByVal lParam As Any) _
As Long
 
Declare Function WritePrivateProfileString _
Lib "Kernel32" Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal _
lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long
 
Dim Chemin As String
Dim NC As Long
Dim Ret As String
 
Sub ChangeImprimanteParDéfaut(Nom As String)
  Chemin = String(260, 0)
  Chemin = Left$(Chemin, GetWindowsDirectory(Chemin, Len(Chemin))) + "\win.ini"
  Ret = String(255, 0)
  NC = GetPrivateProfileString("Devices", Nom, "", Ret, 255, Chemin)
  Ret = Left(Ret, NC)
  WritePrivateProfileString "windows", "device", Nom & "," & Ret, Chemin
End Sub
 
Function ImprimanteParDéfaut() As String
  Chemin = String(260, 0)
  Chemin = Left$(Chemin, GetWindowsDirectory(Chemin, Len(Chemin))) + "\win.ini"
  Ret = String(255, 0)
  NC = GetPrivateProfileString("windows", "device", "", Ret, 255, Chemin)
  Ret = Left(Ret, NC)
  NC = InStr(Ret, ",")
  ImprimanteParDéfaut = Left(Ret, NC - 1)
End Function

et ca sur le clique de mon bouton :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Private Sub CommandButton1_Click()
oldimp = ImprimanteParDéfaut
ChangeImprimanteParDéfaut ("Adobe PDF")
Formulaire.PrintForm
ChangeImprimanteParDéfaut (oldimp)
End Sub

jusque la ca va

Maintenant comment lui donner un nom et un chemin pour l'enregistrement car le but c'est une fois le fichier créé de faire le mail et de le détruire après