Userform en pdf ou mail

Version imprimable

28/12/2015, 17h06
EoWinn

Userform en pdf ou mail
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:

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

Bonsoir,

Essaye comme cela

Code:

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

1 pièce(s) jointe(s)

Salut, code de l'UserForm

Code:

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

29/12/2015, 10h16
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

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

Code:

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

voila ou j'en suis ;)

mis ca dans un module

Code:

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:

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

29/12/2015, 14h08
Oliv-

Ton code pour changer l'imprimante par défaut me laisse dubitatif, mais si cela fonctionne ...

Pour ton pdf regarde le lien dans la signature de KIKI29

Qu'est ce qui n'est pas présent dans le printscreen ?
29/12/2015, 16h13
EoWinn

coucou

me manque mon bas de userform qui est caché par ma barre de tache Windows ou j'ai malheureusement un " * prenez contact avec .......... " :)

mais après toutes ces recherches infructueuse je vais changer mon fusil d'épaule.

j'était parti sur un userform sous Excel par fainéantise. je repart sous VB, vais faire un Form1 :)

Merci a vous tous passez des bonnes fêtes