'Voici le code de la form qui vous permet d'intégrer 'un formulaire d'enregistrement à votre application. ' 'COMMENT RECUPERER CE CODE ? '1 - Enregistrez ce fichier sur votre ordinateur. '2 - Renommez le avec une extension FRM. '3 - Démarrer un nouveau projet Visual Basic* ou ouvrez un projet existant. '4 - Ajoutez le fichier à ce projet. '5 - Double-cliquez sur la form dans l'explorateur de projet pour afficher la form. ' ' '*propriété de MicroSoft ' '********************* VOICI LE CODE DE LA FORM ************************** ' VERSION 5.00 Begin VB.Form frmEnregistrement BorderStyle = 3 'Fixed Dialog Caption = "Enregistrement" ClientHeight = 7965 ClientLeft = 3600 ClientTop = 1335 ClientWidth = 6420 Icon = "frmEnregistrement.frx":0000 KeyPreview = -1 'True LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 7965 ScaleWidth = 6420 ShowInTaskbar = 0 'False StartUpPosition = 2 'CenterScreen Begin VB.CommandButton cmdQuitter Cancel = -1 'True Caption = "&Quitter" Height = 435 Left = 4680 TabIndex = 44 ToolTipText = "Quitter" Top = 7500 Width = 1695 End Begin VB.Frame fraCoordonnees Height = 7395 Left = 60 TabIndex = 31 Top = 0 Width = 6315 Begin VB.Frame fraSupplement Height = 2535 Left = -2700 TabIndex = 53 Top = 4920 Visible = 0 'False Width = 6075 Begin VB.ListBox lstChoix Appearance = 0 'Flat Height = 1005 ItemData = "frmEnregistrement.frx":0442 Left = 3360 List = "frmEnregistrement.frx":0455 TabIndex = 30 ToolTipText = "Liste de connaissance" Top = 720 Visible = 0 'False Width = 1695 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 675 Index = 17 Left = 180 MultiLine = -1 'True TabIndex = 62 ToolTipText = "Remarques et suggestions" Top = 1680 Width = 5715 End Begin VB.TextBox txtCoordonnees Alignment = 2 'Center Appearance = 0 'Flat Height = 255 Index = 16 Left = 3360 MaxLength = 2 TabIndex = 60 ToolTipText = "Remarques et suggestions" Top = 1080 Width = 855 End Begin VB.CommandButton cmdListe Caption = "<" Height = 255 Left = 5100 TabIndex = 26 ToolTipText = "Liste de connaissance" Top = 480 Width = 255 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 15 Left = 1500 TabIndex = 28 ToolTipText = "Remarques et suggestions" Top = 780 Width = 3555 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 14 Left = 3360 Locked = -1 'True TabIndex = 27 ToolTipText = "Comment avez-vous connu ce programme ?" Top = 480 Width = 1695 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Si autre, précisez:" Height = 195 Index = 18 Left = 180 TabIndex = 61 Top = 840 Width = 1260 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Merci de remplir ces quelques petits renseignements facultatifs" BeginProperty Font Name = "MS Serif" Size = 6.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 165 Index = 14 Left = 180 TabIndex = 57 Top = 240 Width = 3780 End Begin VB.Label lblFermer Appearance = 0 'Flat AutoSize = -1 'True BackColor = &H80000005& BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "X" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 270 Left = 5820 TabIndex = 29 ToolTipText = "Fermer" Top = 180 Width = 180 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Vos remarques et suggestions:" Height = 195 Index = 16 Left = 180 TabIndex = 56 Top = 1440 Width = 2160 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Attribuez une note sur 10 à ce programme:" Height = 195 Index = 15 Left = 180 TabIndex = 55 Top = 1140 Width = 3000 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Comment avez-vous connu ce programme ?" Height = 195 Index = 13 Left = 180 TabIndex = 54 Top = 540 Width = 3120 End End Begin VB.CommandButton cmdEnregistrement Caption = "&Afficher" Enabled = 0 'False Height = 435 Left = 4185 TabIndex = 21 ToolTipText = "Afficher le formulaire" Top = 5040 Width = 1335 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 12 Left = 1260 TabIndex = 16 ToolTipText = "Nom du produit" Top = 3840 Width = 4875 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 2 Left = 1260 TabIndex = 6 ToolTipText = "Votre prénom" Top = 720 Width = 1815 End Begin VB.CommandButton cmdPlus Caption = "?" Height = 255 Left = 5760 TabIndex = 17 ToolTipText = "Renseignements complémentaires" Top = 4620 Width = 375 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 0 Left = 1260 TabIndex = 4 ToolTipText = "Votre nom" Top = 360 Width = 1815 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 11 Left = 1260 TabIndex = 15 ToolTipText = "Votre adresse de site Internet" Top = 3180 Width = 4875 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 10 Left = 1260 TabIndex = 14 ToolTipText = "Votre adresse de messagerie" Top = 2820 Width = 4875 End Begin VB.TextBox txtAdresseAuteur Appearance = 0 'Flat Height = 735 Left = 180 Locked = -1 'True MultiLine = -1 'True TabIndex = 23 ToolTipText = "Adresse de l'auteur" Top = 6000 Width = 3915 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 9 Left = 4860 TabIndex = 13 ToolTipText = "Votre numéro de fax" Top = 2460 Width = 1275 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 8 Left = 3000 TabIndex = 12 ToolTipText = "Votre numéro de téléphone" Top = 2460 Width = 1275 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 7 Left = 1260 TabIndex = 11 ToolTipText = "Votre numéro de téléphone mobile" Top = 2460 Width = 1275 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 6 Left = 1260 TabIndex = 10 ToolTipText = "Votre pays" Top = 2100 Width = 4875 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 5 Left = 3060 TabIndex = 9 ToolTipText = "Votre ville" Top = 1740 Width = 3075 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 4 Left = 1260 TabIndex = 8 ToolTipText = "Votre numéro de code postal" Top = 1740 Width = 1275 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 555 Index = 3 Left = 1260 MultiLine = -1 'True TabIndex = 7 ToolTipText = "Votre adresse" Top = 1080 Width = 4875 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 1 Left = 3960 TabIndex = 5 ToolTipText = "Le nom de votre société" Top = 360 Width = 2175 End Begin VB.OptionButton optChoix Appearance = 0 'Flat Caption = "Fichier rtf" ForeColor = &H80000008& Height = 195 Index = 2 Left = 2700 TabIndex = 20 ToolTipText = "Fichier rtf" Top = 5160 Width = 1095 End Begin VB.OptionButton optChoix Appearance = 0 'Flat Caption = "Fichier texte" ForeColor = &H80000008& Height = 195 Index = 1 Left = 1320 TabIndex = 19 ToolTipText = "Fichier texte" Top = 5160 Width = 1155 End Begin VB.OptionButton optChoix Appearance = 0 'Flat Caption = "E-mail" ForeColor = &H80000008& Height = 195 Index = 0 Left = 180 TabIndex = 18 ToolTipText = "e-mail" Top = 5160 Width = 795 End Begin VB.TextBox txtCoordonnees Appearance = 0 'Flat Height = 255 Index = 13 Left = 1260 Locked = -1 'True TabIndex = 59 ToolTipText = "Numéro du produit" Top = 4140 Width = 4875 End Begin VB.CommandButton cmdImprimer Enabled = 0 'False Height = 435 Left = 5580 Picture = "frmEnregistrement.frx":0484 Style = 1 'Graphical TabIndex = 22 ToolTipText = "Imprimer le formulaire" Top = 5040 Width = 555 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Pays:" Height = 195 Index = 17 Left = 180 TabIndex = 58 Top = 2160 Width = 390 End Begin VB.Line Line1 BorderColor = &H00FFFFFF& Index = 2 X1 = 180 X2 = 6120 Y1 = 4920 Y2 = 4920 End Begin VB.Line Line1 BorderColor = &H00FFFFFF& Index = 3 X1 = 180 X2 = 6120 Y1 = 5580 Y2 = 5580 End Begin VB.Label Label4 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Prenez quelques secondes pour répondre à quelques questions.........................." Height = 195 Index = 2 Left = 180 TabIndex = 52 Top = 4680 Width = 5670 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Société:" Height = 195 Index = 12 Left = 3300 TabIndex = 51 Top = 420 Width = 585 End Begin VB.Line Line1 BorderColor = &H00FFFFFF& Index = 1 X1 = 180 X2 = 6120 Y1 = 3660 Y2 = 3660 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Numéro:" Height = 195 Index = 11 Left = 180 TabIndex = 50 Top = 4200 Width = 600 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Produit:" Height = 195 Index = 10 Left = 180 TabIndex = 49 Top = 3900 Width = 540 End Begin VB.Label Label4 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Mes coordonnées:" Height = 195 Index = 3 Left = 180 TabIndex = 48 Top = 5760 Width = 1320 End Begin VB.Label lblSite AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "SITE" BeginProperty Font Name = "Arial" Size = 8.25 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FF0000& Height = 210 Left = 1320 MouseIcon = "frmEnregistrement.frx":0586 MousePointer = 99 'Custom TabIndex = 25 ToolTipText = "Site Internet de l'auteur" Top = 7080 Width = 315 End Begin VB.Label lblMail AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "MAIL" BeginProperty Font Name = "Arial" Size = 8.25 Charset = 0 Weight = 400 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FF0000& Height = 210 Left = 1320 MouseIcon = "frmEnregistrement.frx":0890 MousePointer = 99 'Custom TabIndex = 24 ToolTipText = "Adresse e-mail de l'auteur" Top = 6780 Width = 360 End Begin VB.Label Label4 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "E-mail:" Height = 195 Index = 1 Left = 180 TabIndex = 47 Top = 6780 Width = 465 End Begin VB.Label Label4 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Site Internet:" Height = 195 Index = 0 Left = 180 TabIndex = 46 Top = 7080 Width = 900 End Begin VB.Label lblSociete AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "db2p" BeginProperty Font Name = "Arial" Size = 15.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00C00000& Height = 360 Left = 4980 TabIndex = 45 ToolTipText = "Logo" Top = 6120 Width = 765 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Site Internet:" Height = 195 Index = 9 Left = 180 TabIndex = 41 Top = 3240 Width = 900 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "E-mail:" Height = 195 Index = 8 Left = 180 TabIndex = 40 Top = 2880 Width = 465 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Mobile:" Height = 195 Index = 7 Left = 180 TabIndex = 39 Top = 2520 Width = 510 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Fax:" Height = 195 Index = 6 Left = 4440 TabIndex = 38 Top = 2520 Width = 300 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Tél:" Height = 195 Index = 5 Left = 2640 TabIndex = 37 Top = 2520 Width = 270 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Ville:" Height = 195 Index = 4 Left = 2700 TabIndex = 36 Top = 1800 Width = 330 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Code postal:" Height = 195 Index = 3 Left = 180 TabIndex = 35 Top = 1860 Width = 885 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Adresse:" Height = 195 Index = 2 Left = 180 TabIndex = 34 Top = 1140 Width = 615 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Prénom:" Height = 195 Index = 1 Left = 180 TabIndex = 33 Top = 780 Width = 585 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Nom:" Height = 195 Index = 0 Left = 180 TabIndex = 32 Top = 420 Width = 375 End Begin VB.Line Line1 BorderColor = &H00FFFFFF& Index = 0 X1 = 180 X2 = 6120 Y1 = 4560 Y2 = 4560 End Begin VB.Line Line2 BorderColor = &H00000000& BorderWidth = 2 Index = 0 X1 = 180 X2 = 6120 Y1 = 4560 Y2 = 4560 End Begin VB.Line Line2 BorderColor = &H00000000& BorderWidth = 2 Index = 1 X1 = 180 X2 = 6120 Y1 = 3660 Y2 = 3660 End Begin VB.Line Line1 BorderColor = &H00FFFFFF& Index = 4 X1 = 180 X2 = 6120 Y1 = 5640 Y2 = 5640 End Begin VB.Line Line2 BorderColor = &H00000000& BorderWidth = 2 Index = 2 X1 = 180 X2 = 6120 Y1 = 5640 Y2 = 5640 End Begin VB.Line Line2 BorderColor = &H00000000& BorderWidth = 2 Index = 3 X1 = 180 X2 = 6120 Y1 = 5580 Y2 = 5580 End Begin VB.Line Line2 BorderColor = &H00000000& BorderWidth = 2 Index = 4 X1 = 180 X2 = 6120 Y1 = 4920 Y2 = 4920 End End Begin VB.Frame fraInformation Height = 7395 Left = 60 TabIndex = 42 Top = 0 Width = 6315 Begin VB.CommandButton cmdOK Caption = "&Enregistrement" Enabled = 0 'False Height = 495 Left = 2340 TabIndex = 3 ToolTipText = "Enregistrement" Top = 6780 Width = 1875 End Begin VB.OptionButton optAcceptation Appearance = 0 'Flat Caption = "Je n'accepte pas" ForeColor = &H80000008& Height = 255 Index = 1 Left = 240 TabIndex = 2 ToolTipText = "Je n'accepte pas" Top = 7080 Width = 1635 End Begin VB.OptionButton optAcceptation Appearance = 0 'Flat Caption = "J'accepte" ForeColor = &H80000008& Height = 255 Index = 0 Left = 240 TabIndex = 1 ToolTipText = "J'accepte" Top = 6780 Width = 1155 End Begin VB.TextBox txtInformations Appearance = 0 'Flat Height = 6135 Left = 240 Locked = -1 'True MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 0 ToolTipText = "Informations" Top = 480 Width = 5835 End Begin VB.Label Label2 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Informations" BeginProperty Font Name = "Arial" Size = 9 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 225 Left = 240 TabIndex = 43 Top = 240 Width = 1080 End End End Attribute VB_Name = "frmEnregistrement" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit ' 'VARIABLES Private fichier_html As String 'le formuailre d'enregistrement au format html Private fichier_rtf As String 'le formuailre d'enregistrement au format rtf Private fichier_texte As String 'le formuailre d'enregistrement au format rtf ' 'API Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Public Sub Executer(fichier As String, mode As String, autre_type As Boolean) ' If autre_type = True Then GoTo suite 'adresse e-mail ou site, pas de verification de fichier ' If Verif_Fichier(fichier) = False Then MsgBox fichier & vbCrLf & " est introuvable. Assurez-vous que celui-ci doit se trouver dans le dossier:" & vbCrLf & App.Path, vbCritical, "Fichier introuvable" Exit Sub End If ' suite: Dim rep& rep = ShellExecute(Me.hWnd, mode, fichier, ByVal 0&, 0&, 1) If rep = 31 Then MsgBox "Aucune application associée avec le type de fichier " & UCase$(Right$(fichier, 3)) & " .", vbInformation, "Information" Exit Sub End If ' End Sub Public Sub CreerFichierHtml() ' Dim html As String html = "" Dim num_fich% num_fich = FreeFile fichier_html = chemin_app & "formulaire.htm" ' html = "" & vbCrLf html = html & "" & vbCrLf html = html & "" & vbCrLf html = html & "FORMULAIRE D'ENREGISTREMENT" & vbCrLf html = html & "" & vbCrLf html = html & "" & vbCrLf html = html & "" & vbCrLf html = html & "

FORMULAIRE D'ENREGISTREMENT
Ce " & vbCrLf html = html & "formulaire n'a aucune valeur commerciale. Vous n'avez aucune obligation de l'envoyer. " & vbCrLf html = html & "Il est simplement destiné à savoir à peu près combien " & vbCrLf html = html & "de personnes utilisent ce programme et dans quelle étendue celui-ci " & vbCrLf html = html & "est apprécié. Toutes les données envoyées restent " & vbCrLf html = html & "strictement confidentielles et ne sont en aucun cas sujettes à quelques " & vbCrLf html = html & "commercialisations que ce soit selon la loi de la liberté informatique " & vbCrLf html = html & "en vigueur. Alors, un petit geste, juste 2 minutes de votre temps pour remplir " & vbCrLf html = html & "celui-ci. MERCI.

" & vbCrLf html = html & "
" & vbCrLf html = html & "

COORDONNEES
Societe: " & vbCrLf html = html & "     
Nom: " & vbCrLf html = html & "             " & vbCrLf html = html & "  Prénom: 
Adresse: " & vbCrLf html = html & "  
Code:            " & vbCrLf html = html & " Ville:  
 Pays: " & vbCrLf html = html & "         
Tel: " & vbCrLf html = html & "               " & vbCrLf html = html & " Fax:     Mobile: " & vbCrLf html = html & " 
e-mail:          
Site " & vbCrLf html = html & "Web:    

" & vbCrLf html = html & "

PRODUIT
Nom:            
Numéro: " & vbCrLf html = html & "   

" & vbCrLf html = html & "

RENSEIGNEMENTS (Merci " & vbCrLf html = html & "de remplir ces quelques petits renseignements facultatifs)
 Comment " & vbCrLf html = html & "avez-vous connu ce programme ?     Si autre, précisez:  
 Attribuez une note sur 10 à ce programme:    
 Vos remarques et suggestions:                            

" & vbCrLf html = html & "

Appuyez sur " & vbCrLf html = html & "pour envoyer les données
" html = html & "

" & vbCrLf html = html & "

MERCI d'avoir pris un peu de temps " & vbCrLf html = html & "pour remplir ce formulaire.

" & vbCrLf html = html & "" & vbCrLf html = html & "
" & UCase$(txtCoordonnees(12).Text) & ", version " & App.Major & "." & App.Minor & "." & App.Revision & " - Copyright (c) " & Format(Now, "yyyy") & " - " & lblSociete.Caption & " " & vbCrLf html = html & "
" & vbCrLf html = html & "e-mail: " & lblMail.Caption & "
" & vbCrLf html = html & "site web: " & lblSite.Caption & "" & vbCrLf html = html & "" If Verif_Fichier(fichier_html) = True Then Kill fichier_html 'ouvre le fichier(le cree si il n'existe pas) Open fichier_html For Output As num_fich 'ecrit dans le fichier Print #num_fich, html 'ferme le fichier Close #num_fich End Sub Public Function chemin_app() As String 'donne le chemin du dossier du programme Dim chemin$ chemin = App.Path If Right(chemin, 1) <> "\" Then chemin = chemin & "\" chemin_app = chemin End Function Public Sub Afficher_formulaire(fichier As String, mode As String) ' If Verif_Fichier(fichier) = False Then MsgBox "Fichier d'enregistrement [" & fichier & "] introuvable. Assurez-vous que celui-ci doit se trouver dans le dossier:" & vbCrLf & App.Path, vbCritical, "Fichier introuvable" Exit Sub End If ' Dim rep& rep = ShellExecute(Me.hWnd, mode, fichier, ByVal 0&, 0&, SW_NORMAL) If rep = 31 Then MsgBox "Aucune application associée avec le type de fichier " & UCase$(Right$(fichier, 3)) & " .", vbInformation, "Information" Exit Sub End If ' End Sub Public Sub affichage_infos() ' If Verif_Fichier(chemin_app & "informations.txt") = False Then MsgBox "Impossible d'afficher les informations. Le fichier INFORMATIONS.TXT est introuvable." & vbCrLf & "Celui-ci devrait se trouver dans le dossier: " & App.Path, vbInformation, "Fichier d'informations introuvable" optAcceptation(0).Enabled = False optAcceptation(1).Enabled = False Exit Sub End If ' Dim numero_fichier As Integer numero_fichier = FreeFile Dim temp As String ' ' 'ecrit dans la zone de texte le contenu du fichier Open chemin_app & "informations.txt" For Input As #numero_fichier temp = Input(LOF(numero_fichier), #numero_fichier) Close #numero_fichier txtInformations.Text = temp ' ' ' End Sub Public Function Verif_Fichier(chemin As String) As Boolean 'permet de savoir si le fichier voulu existe 'exemple d'appel: Verif_Fichier("c:\aaaaaaaa\zzzz.txt") If Dir(chemin) <> "" Then Verif_Fichier = True Else Verif_Fichier = False End If End Function Public Sub CreerFichierRtf() ' Dim num_fich% Dim rtf As String rtf = "" num_fich = FreeFile fichier_rtf = chemin_app & "formulaire.rtf" ' ' rtf = "{\rtf1\ansi\deff0{\fonttbl{\f0\fmodern\fprq1\fcharset0 Courier New;}{\f1\fnil\fcharset0 Courier New;}}" & vbCrLf rtf = rtf & "{\colortbl ;\red0\green0\blue0;}" & vbCrLf rtf = rtf & "\viewkind4\uc1\pard\cf1\lang1036\b\f0\fs24 FORMULAIRE D'ENREGISTREMENT\cf0\b0\f1\par" & vbCrLf rtf = rtf & "\fs18 Ce formulaire n'a aucune valeur commerciale. Vous n'avez aucune obligation de l'envoyer. Il est simplement destin\'e9 \'e0 savoir \'e0 peu pr\'e8s combien de personnes utilisent ce programme et dans quelle \'e9tendue ce lui-ci est appr\'e9ci\'e9. Toutes les donn\'e9es envoy\'e9es restent strictement confidentielles et ne sont en aucun cas sujettes \'e0 quelques commercialisations que ce soit selon la loi de la libert\'e9 informatique en vigueur. Alors, un petit geste, juste 2 minutes de votre temps pour remplir celui-ci. MERCI.\par" & vbCrLf rtf = rtf & "\fs20\par" & vbCrLf rtf = rtf & "\ul\b COORDONNEES\par" & vbCrLf rtf = rtf & "\ulnone\b0\par" & vbCrLf rtf = rtf & "Societe: \tab\fs24" & txtCoordonnees(1).Text & "\fs22\par" & vbCrLf rtf = rtf & "\fs20 Nom: \tab\fs24 " & txtCoordonnees(0).Text & "\fs20\tab Pr\'e9nom:\tab\fs24 " & txtCoordonnees(2).Text & "\fs20\par" & vbCrLf rtf = rtf & "Adresse:\tab " & txtCoordonnees(3).Text & "\par" & vbCrLf rtf = rtf & "Code:\tab\fs24 " & txtCoordonnees(4).Text & "\fs20\tab Ville:\tab\fs24 " & txtCoordonnees(5).Text & "\par" & vbCrLf rtf = rtf & "\fs20 Pays:\tab\fs24 " & txtCoordonnees(6).Text & "\par" & vbCrLf rtf = rtf & "\fs20 Tel:\tab\fs24 " & txtCoordonnees(8).Text & "\fs20\tab\tab Fax: \fs24 " & txtCoordonnees(9).Text & "\fs20\tab Mobile: \fs24 " & txtCoordonnees(7).Text & "\par" & vbCrLf rtf = rtf & "\fs20 e-mail:\tab\fs24 " & txtCoordonnees(10).Text & "\par" & vbCrLf rtf = rtf & "\fs20 Site Web:\tab\fs24 " & txtCoordonnees(11).Text & "\par" & vbCrLf rtf = rtf & "\fs20\par" & vbCrLf rtf = rtf & "\ul\b PRODUIT\par" & vbCrLf rtf = rtf & "\ulnone\b0\par" & vbCrLf rtf = rtf & "Nom:\tab\tab\fs24 " & txtCoordonnees(12).Text & "\fs20\par" & vbCrLf rtf = rtf & "Num\'e9ro:\tab\fs24 " & txtCoordonnees(13).Text & "\fs20\par" & vbCrLf rtf = rtf & "\par" & vbCrLf rtf = rtf & "\ul\b RENSEIGNEMENTS\ulnone\b0 \fs18 (Merci de remplir ces quelques petits renseignements facultatifs)\par" & vbCrLf rtf = rtf & "\par" & vbCrLf rtf = rtf & "\fs20 Comment avez-vous connu ce programme ?\tab\fs24 " & txtCoordonnees(14).Text & "\fs20\par" & vbCrLf rtf = rtf & "Si autre, pr\'e9cisez:\tab\fs24 " & txtCoordonnees(15).Text & "\fs20\par" & vbCrLf rtf = rtf & "\par" & vbCrLf rtf = rtf & "Attribuez une note sur 10 \'e0 ce programme:\tab\fs24 " & txtCoordonnees(16).Text & "\fs20\par" & vbCrLf rtf = rtf & "\par" & vbCrLf rtf = rtf & "Vos remarques et suggestions:\par" & vbCrLf rtf = rtf & "\fs24 " & txtCoordonnees(17).Text & "\fs20\par" & vbCrLf rtf = rtf & "\par" & vbCrLf rtf = rtf & "\par" & vbCrLf rtf = rtf & "\b MERCI d'avoir pris un peu de temps pour remplir ce formulaire.\b0\par" & vbCrLf rtf = rtf & "________________________________________________________________\par" & vbCrLf rtf = rtf & UCase$(txtCoordonnees(12).Text) & ", version " & App.Major & "." & App.Minor & "." & App.Revision & " - Copyright (c) " & Format(Now, "yyyy") & " - " & lblSociete.Caption & "\par" & vbCrLf rtf = rtf & "e-mail: \tab " & lblMail.Caption & "\par" & vbCrLf rtf = rtf & "site web:\tab " & lblSite.Caption & "\par" & vbCrLf rtf = rtf & "}" ' If Verif_Fichier(fichier_rtf) = True Then Kill fichier_rtf 'ouvre le fichier(le cree si il n'existe pas) Open fichier_rtf For Output As num_fich 'ecrit dans le fichier Print #num_fich, rtf 'ferme le fichier Close #num_fich ' End Sub Public Sub CreerFichierTexte() ' Dim num_fich% Dim texte As String texte = "" num_fich = FreeFile fichier_texte = chemin_app & "formulaire.txt" ' ' texte = "FORMULAIRE D' ENREGISTREMENT" & vbCrLf texte = texte & "Ce formulaire n'a aucune valeur commerciale. Vous n'avez aucune obligation de l'envoyer." & vbCrLf texte = texte & "Il est simplement destiné à savoir à peu près combien de personnes utilisent ce programme" & vbCrLf texte = texte & "et dans quelle étendue ce lui-ci est apprécié." & vbCrLf texte = texte & "Toutes les données envoyées restent strictement confidentielles et ne sont en aucun cas" & vbCrLf texte = texte & "sujettes à quelques commercialisations que ce soit selon la loi de la liberté informatique en vigueur." & vbCrLf texte = texte & "Alors, un petit geste, juste 2 minutes de votre temps pour remplir celui-ci. MERCI." & vbCrLf texte = texte & "" & vbCrLf texte = texte & "COORDONNEES" & vbCrLf texte = texte & "" & vbCrLf texte = texte & "Societe:" & txtCoordonnees(1).Text & vbCrLf texte = texte & "Nom: " & txtCoordonnees(0).Text & " Prénom:" & txtCoordonnees(2).Text & vbCrLf texte = texte & "Adresse:" & txtCoordonnees(3).Text & vbCrLf texte = texte & "Code: " & txtCoordonnees(4).Text & "Ville: " & txtCoordonnees(5).Text & vbCrLf texte = texte & "Pays: " & txtCoordonnees(6).Text & vbCrLf texte = texte & "Tel: " & txtCoordonnees(8).Text & "Fax: " & txtCoordonnees(9).Text & "Mobile: " & txtCoordonnees(7).Text & vbCrLf texte = texte & "e -mail:" & txtCoordonnees(10).Text & vbCrLf texte = texte & "site web:" & txtCoordonnees(11).Text & vbCrLf texte = texte & "" & vbCrLf texte = texte & "PRODUIT" & vbCrLf texte = texte & "" & vbCrLf texte = texte & "Nom: " & txtCoordonnees(12).Text & vbCrLf texte = texte & "Numéro: " & txtCoordonnees(13).Text & vbCrLf texte = texte & "" & vbCrLf texte = texte & "RENSEIGNEMENTS (Merci de remplir ces quelques petits renseignements facultatifs)" & vbCrLf texte = texte & "" & vbCrLf texte = texte & "Comment avez-vous connu ce programme ? " & txtCoordonnees(14).Text & vbCrLf texte = texte & "Si autre, précisez:" & txtCoordonnees(15).Text & vbCrLf texte = texte & "" & vbCrLf texte = texte & "Attribuez une note sur 10 à ce programme: " & txtCoordonnees(16).Text & vbCrLf texte = texte & "" & vbCrLf texte = texte & "Vos remarques et suggestions:" & vbCrLf texte = texte & txtCoordonnees(17).Text & vbCrLf texte = texte & "" & vbCrLf texte = texte & "MERCI d 'avoir pris un peu de temps pour remplir ce formulaire." & vbCrLf texte = texte & "________________________________________________________________" & vbCrLf texte = texte & UCase$(txtCoordonnees(12).Text) & ", version " & App.Major & "." & App.Minor & "." & App.Revision & " - Copyright (c) " & Format(Now, "yyyy") & " - " & lblSociete.Caption & vbCrLf texte = texte & "e -mail: " & lblMail.Caption & vbCrLf texte = texte & "site web: " & lblSite.Caption & vbCrLf ' If Verif_Fichier(fichier_texte) = True Then Kill fichier_texte 'ouvre le fichier(le cree si il n'existe pas) Open fichier_texte For Output As num_fich 'ecrit dans le fichier Print #num_fich, texte 'ferme le fichier Close #num_fich ' End Sub Private Sub chkEnvoi_Click(Index As Integer) End Sub Private Sub cmdEnregistrement_Click() ' 'verification si il y a des donnees ecrites Dim I As Integer Dim Donnees_OK As Boolean Donnees_OK = False For I = 0 To 17 If txtCoordonnees(I).Text <> "" Then Donnees_OK = True Exit For End If Next I If Donnees_OK = False Then If txtCoordonnees(14).Text = "Autre..." Then MsgBox "Vous n'avez saisi aucune donnée.", vbInformation, "Affichage impossible" Exit Sub End If End If 'verification de l'adresse du site If txtCoordonnees(11).Text <> "" Then If LCase$(Left$(txtCoordonnees(11).Text, 7)) <> LCase$("http://") Then MsgBox "L'adresse de votre site Internet semble non conforme.", vbInformation, "Donnée incorrecte" txtCoordonnees(11).SelLength = Len(txtCoordonnees(11).Text) txtCoordonnees(11).SetFocus Exit Sub End If End If 'verification de l'adresse mail If txtCoordonnees(10).Text <> "" Then Dim Caractere As String Caractere = "" For I = 1 To Len(txtCoordonnees(10).Text) Caractere = Mid$(txtCoordonnees(10), I, 1) If Caractere = "@" Then Exit For End If Next I If Caractere = "" Then GoTo mail_erronee For I = 1 To Len(txtCoordonnees(10).Text) Caractere = Mid$(txtCoordonnees(10).Text, I, 1) If Caractere = "." Then Exit For End If Next I If Caractere <> "" Then GoTo suite mail_erronee: MsgBox "Veuillez saisir une adresse e-mail au format NOM@DOMAINE.XX", vbInformation, "Donnée incorrecte" txtCoordonnees(10).SelLength = Len(txtCoordonnees(10).Text) txtCoordonnees(10).SetFocus Exit Sub End If suite: ' 'mail If optChoix(0).Value = True Then CreerFichierHtml Call Executer(fichier_html, "open", False) End If ' 'fichier texte If optChoix(1).Value = True Then CreerFichierTexte Call Executer(fichier_texte, "open", False) End If ' 'fichier rtf If optChoix(2).Value = True Then CreerFichierRtf Call Executer(fichier_rtf, "open", False) End If ' End Sub Private Sub cmdImprimer_Click() ' 'verification si il y a des donnees ecrites Dim I As Integer Dim Donnees_OK As Boolean Donnees_OK = False For I = 0 To 17 If txtCoordonnees(I).Text <> "" Then Donnees_OK = True Exit For End If Next I If Donnees_OK = False Then If txtCoordonnees(14).Text = "Autre..." Then MsgBox "Vous n'avez saisi aucune donnée.", vbInformation, "Impression impossible" Exit Sub End If End If 'verification de l'adresse du site If txtCoordonnees(11).Text <> "" Then If LCase$(Left$(txtCoordonnees(11).Text, 7)) <> LCase$("http://") Then MsgBox "L'adresse de votre site Internet semble non conforme.", vbInformation, "Donnée incorrecte" txtCoordonnees(11).SelLength = Len(txtCoordonnees(11).Text) txtCoordonnees(11).SetFocus Exit Sub End If End If 'verification de l'adresse mail If txtCoordonnees(10).Text <> "" Then Dim Caractere As String Caractere = "" For I = 1 To Len(txtCoordonnees(10).Text) Caractere = Mid$(txtCoordonnees(10), I, 1) If Caractere = "@" Then Exit For End If Next I If Caractere = "" Then GoTo mail_erronee For I = 1 To Len(txtCoordonnees(10).Text) Caractere = Mid$(txtCoordonnees(10).Text, I, 1) If Caractere = "." Then Exit For End If Next I If Caractere <> "" Then GoTo suite mail_erronee: MsgBox "Veuillez saisir une adresse e-mail au format NOM@DOMAINE.XX", vbInformation, "Donnée incorrecte" txtCoordonnees(10).SelLength = Len(txtCoordonnees(10).Text) txtCoordonnees(10).SetFocus Exit Sub End If suite: ' 'mail If optChoix(0).Value = True Then CreerFichierHtml Call Executer(fichier_html, "print", False) End If ' 'fichier texte If optChoix(1).Value = True Then CreerFichierTexte Call Executer(fichier_texte, "print", False) End If ' 'fichier rtf If optChoix(2).Value = True Then CreerFichierRtf Call Executer(fichier_rtf, "print", False) End If ' End Sub Private Sub cmdListe_Click() lstChoix.Visible = Not lstChoix.Visible End Sub Private Sub cmdOK_Click() fraInformation.Visible = False fraSupplement.Visible = False fraCoordonnees.Visible = True End Sub Private Sub cmdPlus_Click() With fraSupplement .Visible = Not .Visible .Top = 2040 .Left = 120 End With End Sub Private Sub cmdQuitter_Click() End End Sub Private Sub Form_Load() 'formulaire d'enregistrement à integrer dans votre application 'exemple d'appel de la fenetre. celle ci s'appelle frmEnregistrement 'en appuyant sur un bouton appele Command1 'vous de vez creer egalement un fichier nomme informations.txt et celui-ci 'doit se trouver dans le même dossier que le formulaire 'c'est le contenu de ce fichier qui sera affiche dans la zone d'information ' '******DEBUT DU CODE 'Private Sub Command1_Click() 'With frmEnregistrement 'position de la fenetre '.Top = X 'mettez ici la position en hauteur X de la fenetre '.Left = Y 'mettez ici la position en hauteur Y de la fenetre '.Show vbModal 'affiche la fenetre 'End With 'end sub '******FIN DE CODE ' 'CI-DESSOUS VOUS POUVEZ PARAMETRER DIVERS AFFICHAGE 'AFFICHAGE DES DONNEES 'coordonnees de l'auteur lblSociete.Caption = "db2p" 'nom de votre societe ou autre txtAdresseAuteur.Text = "M. BODIN Thierry" & vbCrLf & "12 rue de la Chalotais" & vbCrLf & "35510 CESSON-SEVIGNE" 'coordonnees de votre societe lblMail.Caption = "db2p@libertysurf.fr" 'mail de votre societe lblMail.Tag = "mailto:" & lblMail.Caption 'ne pas changer lblSite.Caption = "http://perso.libertysurf.fr/db2p" 'adresse internet de votre societe 'nom et numero du produit txtCoordonnees(12).Text = "GESTIONNAIRE DE PLANS" 'NOM DU PRODUIT txtCoordonnees(13).Text = "XXX" 'NUMERO DU PRODUIT 'informations de la zone de texte Call affichage_infos 'affiche le message d'information contenu dans le fichier informations.txt.ce fichier doit se trouver dans le même dossier que le formulaire ' ' 'CODE A NE PAS CHANGER txtCoordonnees(12).Enabled = False txtCoordonnees(13).Enabled = False fraInformation.Visible = True fraSupplement.Visible = False fraCoordonnees.Visible = False ' End Sub Private Sub Form_QueryUnload(Cancel As Integer, Unload As Integer) End End Sub Private Sub fraSupplement_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) lstChoix.Visible = False End Sub Private Sub lblFermer_Click() fraSupplement.Visible = False End Sub Private Sub lblMail_Click() ' Call Executer(lblMail.Tag, "open", True) ' End Sub Private Sub lblSite_Click() ' Call Executer(lblSite.Caption, "open", True) ' End Sub Private Sub lstChoix_Click() lstChoix.Visible = False txtCoordonnees(14).Text = lstChoix.Text If lstChoix.Text = "Autre..." Then txtCoordonnees(15).SetFocus End Sub Private Sub optAcceptation_Click(Index As Integer) ' cmdOK.Enabled = IIf(Index = 0, True, False) ' End Sub Private Sub optChoix_Click(Index As Integer) cmdEnregistrement.Enabled = optChoix(Index).Value cmdImprimer.Enabled = optChoix(Index).Value End Sub Private Sub txtCoordonnees_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyReturn Then If Index < 11 Then txtCoordonnees(Index + 1).SetFocus End If End Sub Private Sub txtCoordonnees_KeyPress(Index As Integer, KeyAscii As Integer) If Index = 16 Or Index = 7 Or Index = 8 Or Index = 9 Then If KeyAscii = 8 Then Exit Sub If InStr("0123456789", Chr(KeyAscii)) = 0 Then KeyAscii = 0 End If End Sub