Visual Basic, VB6, VB.NET, VB 2005, VB CodeS-SourceS

CodeS-SourceS est hébergé par Frontier.fr

Ce site au démarrage

begin process at 2012 02 13 08:34:44

Accueil Codes Tutoriels Forum Livres Emploi Services Connexion

Trouver un code source :

dans

[ Dernières recherches ]

Accueil >

OCX ENVOIE EMAIL VERSION 2

Information sur la source

Note :

8,28 / 10

Catégorie :Control Niveau :Initié Date de création :18/09/2004 Date de mise à jour :19/09/2004 00:27:15 Vu / téléchargé :9 603 / 1 924

Auteur : pcpunch

Ecrire un message privé

Site perso

Commentaire sur cette source (32)

Ajouter un commentaire et/ou une note

Description

Cliquez pour voir la capture en taille normale

Une nouvelle mouture de mon ocx d'envoie d'Email, cette ocx utilise un control winsock afin de faciliter l'envoie d'email avec piéces jointes. Récement je me suis servir de cette ocx, mais je me suis aperçu qu'il fonctionné trés mal, voila pourquoi je le repost en version 2, aprés qq test il m'apparait trés stable.

J'ai joint un exemple complet d'utilisation de l'ocx.

PS: attention pour les comptes Hotmail le courrier arrive parfois dans le courrier indésirable, alors verifier avant de de dire qu'il ne fonctionne pas!!!!!!

Source

'Commandes :
'***********
'Email1.SeveurSmtp = le serveur smtp (Generalement Smtp.Fai.fr)
'Email1.PieceJointeAjout "C:\fichier.ext"
'Email1.PieceJointeSuppr "C:\fichier.ext"
'Email1.Envoie Email Expediteur,Email Destinataire, Sujet , Message
'Cette Ocx posséde les Evenements Suivant :
'************************************
'Private Sub Email1_Reponse(Evenement As String, TxtServeur As String)
'Evenement : interprétation de la reponse du serveur
'TxtServeur : la reponse du serveur
'Private Sub Email1_Progression(Encours As Long, Total As Long, Pourcent As Integer)
'Encours : renvoie le nb octects envoyé
'Total : le nb total d'octects a envoyer
'Pourcent : le pourcentage effectué
'Private Sub Email1_FichiersJoints(nb As Integer, Liste As String)
'nb : renvoie le nb total de fichier(s) joint(s)
'liste : renvoie le path des fichiers joints avec pour séparateur la virgule
'Exemple "c:\fichier.txt , d:\image.jpg"
'Private Sub Email1_Encodage(Enabled As Boolean, Fichier As String, Pourcent As Integer)
'Enabled : renvoie true si encodage en cours sinon false
'fichier : le nom du fichier en cours d'encodage
'Pourcant : le pourcentage d'encodage effectué du fichier
'PS pour joindre un fichier il est nécéssaire de faire un ecodageUU
'mais la fonction d'encodageUU du controle n'est pas optimisé
'si qq peu m'aider a l'optimiser car je la trouve assez longue...

'Commandes :
'***********
'Email1.SeveurSmtp = le serveur smtp (Generalement Smtp.Fai.fr)
'Email1.PieceJointeAjout "C:\fichier.ext"
'Email1.PieceJointeSuppr "C:\fichier.ext"
'Email1.Envoie Email Expediteur,Email Destinataire, Sujet , Message

'Cette Ocx posséde les Evenements Suivant :
'************************************

'Private Sub Email1_Reponse(Evenement As String, TxtServeur As String)
'Evenement : interprétation de la reponse du serveur
'TxtServeur : la reponse du serveur

'Private Sub Email1_Progression(Encours As Long, Total As Long, Pourcent As Integer)
'Encours : renvoie le nb octects envoyé
'Total : le nb total d'octects a envoyer
'Pourcent : le pourcentage effectué

'Private Sub Email1_FichiersJoints(nb As Integer, Liste As String)
'nb : renvoie le nb total de fichier(s) joint(s)
'liste : renvoie le path des fichiers joints avec pour séparateur la virgule
'Exemple "c:\fichier.txt , d:\image.jpg"

'Private Sub Email1_Encodage(Enabled As Boolean, Fichier As String, Pourcent As Integer)
'Enabled : renvoie true si encodage en cours sinon false
'fichier : le nom du fichier en cours d'encodage
'Pourcant : le pourcentage d'encodage effectué du fichier
'PS pour joindre un fichier il est nécéssaire de faire un ecodageUU
'mais la fonction d'encodageUU du controle n'est pas optimisé
'si qq peu m'aider a l'optimiser car je la trouve assez longue...

Conclusion

Ps : Maitenant je pense y inclure une partie protocole Pop pour la lecture d'Email.

J'espére que ce controle vous sera utilise......

++

Fichier Zip

Les Membres Club peuvent télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Form1.frm 15 570 octets
Form1.frx3 300 octets
Groupe1.vbg41 octets
Projet1.vbp 872 octets
Projet1.vbw 88 octets
Projet2.vbp 727 octets
Projet2.vbw 50 octets
UserControl1.ctl 13 653 octets
UserControl1.ctx1 876 octets

Télécharger le zip

Historique

19 septembre 2004 00:27:15 :: Maj du Zip : j'avais oublié le fichier ctl!!!!

Sources du même auteur

SIMON EN VB

GRAVURE CD AVEC NEROCMD DEPUIS APPLI VB

RADIO SUR INTERNET

AFFICHE DES TITULAIRES FOOTBALL (MCFOOTMANAGER)

IMPRESSION LABEL DVD

Toutes les sources de pcpunch

Sources de la même categorie

COMMUNICATION MODBUS MASTER par sergelapointe

DÉPLACEMENT AVEC FLÈCHES DANS UN PAVÉ DE TEXTBOX 9X9 DYNAMIQ... par EhJoe

CONTROLSTARS EN RÉPONSE À JAKNIGHT007 par bigboss9

CALENDRIER ANNUEL NORME ISO par Prog1001

CONTROLE STARS par jaknight007

Toutes les sources de la catégorie Control

Commentaires et avis

Commentaire de FeelCode le 18/09/2004 21:58:49

Sa peux servire :)
bon je ne pensse pas que sa me serve euh mai petit detaile, tu pourrai faire 1 zip pour chaque projet parce que c est un peux le boxon là

Ensuite je suis H.S et que je pub mai bon j'ai bien galerer pour trouve le truc qui me plaisais.

mai sa peut interesser du monde, ceux qui veule plus de spam virus et autre merdoum essayer mailwasher c'est bien leger et travaille directement sur le serveur ce configure aussi facilment que OE
gratuis aussi. :)

Commentaire de pcpunch le 19/09/2004 00:12:08

Un zip pour chaque projet ???????
le premier projet c'est l exemple d'utilisation, le 2eme c'est la source de l'ocx !!!! Normal qu'il y en ai 2!!!!

Sinon j'ai pas compris grand chose a ton commentaire ??

"Ensuite je suis H.S et que je pub mai bon j'ai bien galerer pour trouve le truc qui me plaisais...... etc..."

Ps: je sais pas qui a mis 1, mais il est grand temp que l'on autorise que les personnes qui post a noter et d'identifier les noteurs (je l'ai deja demandé au admin mais apparement tien ne bouge) , car la c les boules des heures de taff et un commentaire ou l'on pige que dalle et 1/10 lol, je même envie de virer ma src et de la dev pour moi simplement.....
En conclusion si qq pense la mm chose que moi vous serait gentil de mettre des 10 afin de monter la note, car vu le nb de src merdiques que j'ai vu ici et le code de mon ocx, ben ca mérite au mini 8 a mon avis!!!

++

Commentaire de BruNews le 19/09/2004 00:18:21 administrateur CS

Du calme pcpunch tu n'es plus un gamin, on va l'enlever ce 1, encore une note d'un cancre qui croit a l'anonymat.
Cessez donc de regarder les notes, faut faire comme si ça n'existait pas.

Bonne continuation.

Commentaire de pcpunch le 19/09/2004 00:22:03

Merci Brunews mais je trouve que c assez enervant!!! je vien d'envoyer un post concernant le system de notation.

il serait franchement mieux d autoriser seulement les membres identifié a voter et peu etre mm un détails sur la note (Votant et note).

Enfin c'est la vie......

Commentaire de BruNews le 19/09/2004 00:32:01 administrateur CS

J'avais aussi propose cela pour les notes mais ça necessitait trop de modifs et consommait trop de ressources pour notre faible serveur.
Le mieux serait la suppression de ces notes qui ne servent a rien, en attendant ignorons les.

Commentaire de FeelCode le 19/09/2004 07:19:09

pcpunch

Relaxe j'y suis pour rien :)
je t'ai dis que j'ai regarderai en temp voulu, le probleme c'est que j'ai pas encore fait de sauvgarde de ma config toutt neuve donc je ne veux pas y inserer des control qui ne son pas lier aux systeme

BruNews a raison les notes ne veule rien dire car moi a titre perssonnele je me fie aux critique de ceux qui on poster.

je parlerai plus franchment mai bon sa passerai pas la censure lol.

ensuite pour le reste sa concerne un logiciel pour relever les mail que j'aprècie grandment j'ai pas faire de la pub mai bon il merite d'être plus connu de plus si tout le monde l'utilisait il n'y aurais plus de spam.(enfin quan dje dis plus c'est peut être exagerer mai dison presque lol)

pour le moment je te mai pas de note je t'envoiye un petit message en pv :)

Commentaire de azerty25 le 19/09/2004 08:21:50

pcpunch, t'énerve pas, moi, j'ai cracké quand j'ai vu le zoli e-mail recu avec succès dans la boiboite :)
Par contre, certains serveurs nécessitent une identification, comme yahoo, tu pourrait peut etre essayer d'intégrer cette fonction ;)
Moi qui voulait il y a déja un certains temps faire un logiciel de gestion des mails complet comme OutlookExpress et qui ai abandonné car j'avait pas envie de faire la gestion des sortants, je vais peut etre pouvoir recommancer ;)

Commentaire de jipef le 19/09/2004 09:05:51

TRES BIEN pour l'envoi de mail
moi j'attends ta reception d'EMAIL sans OutLock bien sur , mais quelque soit la messagerie par défaut le controle mapimessage ne marche u'avec outlock

a te lire salut

Commentaire de azerty25 le 19/09/2004 09:08:20

Il y a déja des gens qui l'on fait sur ce site si des fois ça peut pas attendre ;)

Commentaire de NISANDSYSTEMS le 19/09/2004 12:17:52

Interessant dans l'ensemble.
Ca fonctionne bien ,c'est propre,clair et precis.
Que demander de plus.

Bon travail
@+
Nisand-Systems

Commentaire de marm0tte le 19/09/2004 13:27:10

Je suis agréablement surpris, justement, apres avoir essaié ta version 1, ben la ca marche :]
Bonne continuation
10/10
++

Commentaire de jipef le 20/09/2004 09:29:42

je suis interessé pour la partie protocole Pop pour la lecture d'Email.( uniquement avec WINSOCK ??
pour detecter la présence j'utilise le source 2515 qui marche trés bien
Mais il manque la lecture de l'objet et des pieces jointes

A propos ou trouve tu les commandes de WINSOCK car le help de VB est peu bavard ??

Pour azerty25 peux tu m'en dire plus ???

Commentaire de pcpunch le 20/09/2004 12:45:14

jipef :

Oui je suis en train d'ajouter la lecture d'email (protocole pop avec winsock). ce sera certainement pour la v3 de l'ocx. Mais j'ai déja deposer une src utilisant winsock pour relever les emails d'un compte (proto pop): regarde dans mes src.
Ceci dit elle ne releve pas le msg car je me heurte un un probléme d'interprétation qd le mail est en html. SInon au niveau des piéces jointes je n'est pas encore abordé le probléme. Mais je me demande si le protocole Imap n'est pas plus adapter (A voir...)

sinon pour les commandes de winsock, je me sert surtout des src déposé ici et du forum. mais une fois qq commande de base assimilé, il est trés facile a envoyé.

Pour les protocole d'utilise les RFC disponible ici dans le moteur de recherche....

voila ++

Commentaire de azerty25 le 20/09/2004 17:57:40

Il y a plusieurs sources postées sur le site pour le pop, avec piece jointe ou nom, un parseur, etc et d'autres comme une d'akhenaton si je me souvient bien qui explique les commandes

Commentaire de Cafeine911 le 22/09/2004 08:47:52

Bonjour,
ton ocx m'interresse, car j'utilise les controles MAPI
et que je voudrais m'en libéré, car quand le serveur de mail est arreté ou injoignable le code peut s'arrêter et bloquer le prog qui l'utilise.
J'ai juste débrancher mon cable réseau et j'ai eu :

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
RaiseEvent Reponse(Description, Scode)
End Sub

une erreur sur scode.

tu pourrais peut etre modifier ta source en testant si le pc est connecté au réseau et si oui si le serveur de mail est down de prévoir le stockage du mail(et pieces jointes) et de l'envoi dès que le serveur est dispo, car je souhaiterais l'intégré(si tu me le permet) dans une appli qui envoi des mails en interne (serveur mail interne)quand un programme est terminé.

je vais regardé de mon coté quand j'aurais un peu plus de temps. sinon très bien.10/10.

Commentaire de pcpunch le 22/09/2004 21:46:18

Oui il est tres facile de savoir si le pc est connecté au net avec les api, de plus il suffirait d'utiliser un timer afin de stocké et envoyer les mail une fois le pc connecté.

Mais c'est un ocx et je pense que c'est application qui doit gérer ça!!! , le projet est simplement joint pour montrer un exemple d'utilisation de l'ocx. Comme le dit le tritre ce code est un : OCX ENVOIE EMAIL et non une application pour envoyer des mails.

Ps: je suis en train de faire un client de méssagerie :
- avec le protocole pop pour le courrier entrant
- et cette ocx pour le courrier sortant.

Le client est opérationnel, mais je me heurte a un probléme de parsing du méssage récupérer. Malgres le commentaire d'AZERTY25 je n'ai trouver aucun parseur d'email (mime je crois) qui fonctionne..... Donc si qq a une info???
++

Commentaire de olivierXIII le 23/10/2004 11:18:44

Il y a un gros probleme lors du codage du fichier joint. Pour 1Mo le temps est ENORME. En fait la progression commence rapidement puis ralenti de plus en plus, en consommant tout le CPU.
Le problème viens de la ligne du genre
strResult = strResult + strTemp + vbcrlf
c'est extremement long!
Il faut faire un tableau avec toutes les strTemp, puis utiliser l'instruction join de vb pour assembler le tableau dans strResult, avec vbCrLf en delimiter.
Bien sur, je ne critique pas en disant, fait-ci, fait-ca, donc je joint la procedure optimisée. La conversion d'un Mo se fait en 3s chez moi maintenant, ce qui est largement acceptable.
Sinon le fichier que je recois dans ma boite est exactement le même que celui envoyé! C'est cool.
Une derniere chose, l'évenement progression ne tient pas compte de l'envoi de la pièce jointe, pourtant c'est ca qui prend le plus de temps. Les transaction de du type HELO/RCPT/DATA etc. ne sont pas longues et, je pense, ne méritent pas d'être intégrée dans la progression.
J'ai donc modifié le code pour allouer 5% de la progression a la "bufferisation" du fichier a envoyer, et 95% lié a l'évenement Winsock1_SendProgress.
Donc si mes modifs te plaisent, intégre les, sinon tant pis, je garderait ca pour moi (c'est pas le principe de vbfrance)

___________________________________________________
___________________________________________________

Dim MailEmeteur As String
Dim NomEmeteur As String
Dim MailRecepteur As String
Dim NomRecepteur As String
Dim Sujet As String
Dim Msg As String
Dim DataFile
Dim Fichiers() As String
Dim Etape As Integer
Dim i As Long
Dim max As Long
Dim Pos As Long
Dim EnvFic As Boolean
Dim X As Integer
Dim FichierJoint As Boolean
Event Reponse(Evenement As String, TxtServeur As String)
Event FichiersJoints(nb As Integer, Liste As String)
'Valeurs de propriétés par défaut:
Const m_def_SeveurSmtp = ""
'Variables de propriétés:
Dim m_SeveurSmtp As String
'Déclarations d'événements:
Event Progression(Encours As Long, Total As Long, Pourcent As Integer)
Event Encodage(Enabled As Boolean, Fichier As String, Pourcent As Integer)
Event EnvoiComplet()

Private Function Recup(ByVal temp As String, code As Integer) As Boolean
    If Val(Mid(temp, 1, 3)) = code Then
        Recup = True
    Else
        Recup = False
    End If
End Function

Private Function UUEncodeFile(strFilePath As String) As String
    Dim intFile As Integer 'file handler
    Dim intTempFile As Integer 'temp file
    Dim lFileSize As Long 'size of the file
    Dim strFilename As String 'name of the file
    Dim strFileData As String 'file data chunk
    Dim lEncodedLines As Long 'number of encoded lines
    Dim strTempLine() As String 'temporary string
    Dim i As Long 'loop counter
    Dim j As Integer 'loop counter

    Dim strResult As String
    '
    'Get file name
    strFilename = Mid$(strFilePath, InStrRev(strFilePath, "\") + 1)
    '
    'Insert first marker: "begin 664 ..."
    strResult = "begin 664 " + strFilename + vbCrLf
    '
    'Get file size
    lFileSize = FileLen(strFilePath)
    lEncodedLines = lFileSize \ 45 + 1
    ReDim strTempLine(lEncodedLines)
    '
    'Prepare buffer to retrieve data from
    'the file by 45 symbols chunks
    strFileData = Space(45)
    '
    intFile = FreeFile
    '
    Open strFilePath For Binary As intFile
    'Get intFile, , strFileData
        For i = 1 To lEncodedLines

        DoEvents
        'Read file data by 45-bytes cnunks
        '
        If i = lEncodedLines Then
        'Last line of encoded data often is not
        'equal to 45, therefore we need to change
        'size of the buffer
        strFileData = Space(lFileSize Mod 45)
        End If
        'Retrieve data chunk from file to the buffer
        Get intFile, , strFileData
        'Add first symbol to encoded string that informs
        'about quantity of symbols in encoded string.
        'More often "M" symbol is used.
        strTempLine(i) = Chr(Len(strFileData) + 32)
        '
        If i = lEncodedLines And (Len(strFileData) Mod 3) Then
        'If the last line is processed and length of
        'source data is not a number divisible by 3, add one or two
        'blankspace symbols
        strFileData = strFileData + Space(3 - (Len(strFileData) Mod 3))
        End If

            For j = 1 To Len(strFileData) Step 3
            'DoEvents
            'Breake each 3 (8-bits) bytes to 4 (6-bits) bytes
            '
            '1 byte
            strTempLine(i) = strTempLine(i) + Chr(Asc(Mid(strFileData, j, 1)) \ 4 + 32)
            '2 byte
            strTempLine(i) = strTempLine(i) + Chr((Asc(Mid(strFileData, j, 1)) Mod 4) * 16 + Asc(Mid(strFileData, j + 1, 1)) \ 16 + 32)
            '3 byte
            strTempLine(i) = strTempLine(i) + Chr((Asc(Mid(strFileData, j + 1, 1)) Mod 16) * 4 + Asc(Mid(strFileData, j + 2, 1)) \ 64 + 32)
            '4 byte
            strTempLine(i) = strTempLine(i) + Chr(Asc(Mid(strFileData, j + 2, 1)) Mod 64 + 32)
            Next j

    'replace " " with "`"
    strTempLine(i) = Replace(strTempLine(i), " ", "`")
    'add encoded line to result buffer
    'reset line buffer
    'strTempLine = ""

        RaiseEvent Reponse("EncodageUU en cours", "Préparation de(s) fichier(s)")
        RaiseEvent Encodage(True, strFilename, Fix(Str(i * 100) / lEncodedLines))
    Next i
    Close intFile

    strResult = "begin 664 " + strFilename + Join(strTempLine, vbCrLf)
    Clipboard.Clear
    Clipboard.SetText strResult

    'add the end marker
    strResult = strResult & "`" & vbCrLf + "end" + vbCrLf
    'asign return value
    UUEncodeFile = strResult
    RaiseEvent Encodage(False, strFilename, Fix(Str(i * 100) / lEncodedLines))
End Function

Private Sub UserControl_Resize()
If Ambient.UserMode = True Then Image1.Visible = False Else Image1.Visible = True
UserControl.Width = Image1.Width
UserControl.Height = Image1.Height
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim Temp_Recep As String, Temp_Envoi As String
    Dim ret

    Winsock1.GetData Temp_Recep, vbString

    Select Case Etape
    Case 0
    EnvFic = False
        If Recup(Temp_Recep, 220) Then
            '''''''''''' Recup du nom du serveur pour la commande "HELO {Nom du serveur}"
            Temp_Envoi = "HELO " & m_SeveurSmtp & vbCrLf
            Envoyer (Temp_Envoi)
            RaiseEvent Reponse("Connexion", Temp_Recep)

        Else
           RaiseEvent Reponse(Temp_Recep, Temp_Recep)
        End If
    Case 1          'On est connecté et on a envoyer "HELO {Nom du serveur}"
        If Recup(Temp_Recep, 250) Then
            '''''''''''' Le Helo est bien pris en compte et on peux commencer à envoyer...
            Temp_Envoi = "MAIL FROM: " & "<" & MailEmeteur & ">" & vbCrLf
           Envoyer (Temp_Envoi)
            RaiseEvent Reponse("Connecté...", Temp_Recep)
        Else
            '''''''''''' Le HELO est rejeté
            RaiseEvent Reponse(Temp_Recep, Temp_Recep)
        End If
    Case 2
        If Recup(Temp_Recep, 250) Then
            '''''''''''' Le MAIL FROM: est accepté
            Temp_Envoi = "RCPT TO: " & "<" & MailRecepteur & ">" & vbCrLf
            Envoyer (Temp_Envoi)
            RaiseEvent Reponse("Mail From accepté...", Temp_Recep)
        Else
            '''''''''''' Le MAIL FROM: n'est pas accepté
            RaiseEvent Reponse(Temp_Recep, Temp_Recep)
        End If
    Case 3
        If Recup(Temp_Recep, 250) Then
            '''''''''''' Le RCPT est accepté, on a fait le plus dur ;)
            Temp_Envoi = "DATA" & vbCrLf
            Envoyer (Temp_Envoi)
            RaiseEvent Reponse("RCPT est accepté", Temp_Recep)
        Else
            '''''''''''' Le serveur n'est pas open relay ou alors le destinataire est inconnu
            RaiseEvent Reponse("Le serveur n'est pas open relay ou alors le destinataire est inconnu", Temp_Recep)
        End If
    Case 4
        If Recup(Temp_Recep, 354) Then
            Temp_Envoi = ""
            '''''''''''' Remplir les champs correspondant à l'emetteur
                Temp_Envoi = "From: " & Chr(34) & NomEmeteur & Chr(34) & " " & "<" & MailEmeteur & ">" & vbCrLf
                'Envoyer (Temp_Envoi)
            End If

            ''''''''''' Remplir les champs correspondant au destinataire
            Temp_Envoi = Temp_Envoi & "To: " & Chr(34) & NomRecepteur & Chr(34) & " " & "<" & MailRecepteur & ">" & vbCrLf

            ''''''''''' Ajouter le sujet du mail
            Temp_Envoi = Temp_Envoi & "Subject: " & Sujet & vbCrLf & vbCrLf '2 sauts de lignes pour dire que l'on passe au corps du msg

            ''''''''''' envoi fichier joint
            If FichierJoint Then
                Temp_Envoi = Temp_Envoi & DataFile & vbCrLf
            End If

            'Temp_Envoi = Temp_Envoi & datafile & vbCrLf
            Temp_Envoi = Temp_Envoi & Msg & vbCrLf & "." & vbCrLf
            ''''''''''' On Envoie tout
            EnvFic = True
            Envoyer (Temp_Envoi)
            RaiseEvent Reponse("Envoi Email en cours...", Temp_Recep)
        Case 5
            If Not Recup(Temp_Recep, 250) Then
                ''''''' Si pb lors de la fin du message
                RaiseEvent Reponse(Temp_Recep, Temp_Recep)
            Else
                 RaiseEvent Reponse("Email envoyé avec succés...", Temp_Recep)
                 RaiseEvent EnvoiComplet
                 Erase Fichiers
                 X = 0
                 FichierJoint = False
                 RaiseEvent FichiersJoints(X, "")
            End If
                Winsock1.SendData ("QUIT")
    End Select
    Etape = Etape + 1
End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    RaiseEvent Reponse(Description, Str(Number))
End Sub
Public Function Envoie(MailSender As String, Mail As String, Subject As String, Message As String)
   RaiseEvent Encodage(False, "", 0)
    DataFile = vbNullString
    Winsock1.Close
    Etape = 0
    MailEmeteur = MailSender
    NomEmeteur = Left(MailSender, InStr(MailSender, "@") - 1) 'Sender
    MailRecepteur = Mail
    NomRecepteur = Left(Mail, InStr(Mail, "@") - 1)
    Sujet = Subject
    Msg = Message


   'Longeur total du mail
   Pos = 0
   max = 0
max = Len("HELO " & m_SeveurSmtp & vbCrLf) + Len("MAIL FROM: " & "<" & MailEmeteur & ">" & vbCrLf) _
+ Len("RCPT TO: " & "<" & MailRecepteur & ">" & vbCrLf) + Len("DATA" & vbCrLf) + Len("From: " & Chr(34) & NomEmeteur & Chr(34) & " " & "<" & MailEmeteur & ">" & vbCrLf) _
+ Len("To: " & Chr(34) & NomRecepteur & Chr(34) & " " & "<" & MailRecepteur & ">" & vbCrLf) + Len("Subject: " & Sujet & vbCrLf & vbCrLf) _
+ Len(Msg & vbCrLf & "." & vbCrLf)
max = max + 4 'Difference ?????

'+ fichier(s) joint(s) Si existe
            If FichierJoint Then


                    For i = 0 To UBound(Fichiers)
                    DoEvents
                    DataFile = DataFile & UUEncodeFile(Fichiers(i))
                    max = max + Len(DataFile & vbCrLf)
                    Next i
            End If


RaiseEvent Progression(Pos, max, 0)
    'connection au serveur port 25
    Winsock1.Connect m_SeveurSmtp, 25
End Function

Public Property Get SeveurSmtp() As String
    SeveurSmtp = m_SeveurSmtp
End Property

Public Property Let SeveurSmtp(ByVal New_SeveurSmtp As String)
    m_SeveurSmtp = New_SeveurSmtp
    PropertyChanged "SeveurSmtp"
End Property

'Initialiser les propriétés pour le contrôle utilisateur
Private Sub UserControl_InitProperties()
    FichierJoint = False
    m_SeveurSmtp = m_def_SeveurSmtp
End Sub

'Charger les valeurs des propriétés à partir du stockage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_SeveurSmtp = PropBag.ReadProperty("SeveurSmtp", m_def_SeveurSmtp)
End Sub

'Écrire les valeurs des propriétés dans le stockage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("SeveurSmtp", m_SeveurSmtp, m_def_SeveurSmtp)
End Sub

Private Sub Envoyer(temp As String)
RaiseEvent Progression(0, max, 0)
RaiseEvent Reponse("Mise en buffer de l'envoi", "")

Dim a As Long
Dim Vartmp As String

If InStr(1, temp, vbCrLf & vbCrLf) = 0 Then
    For a = 1 To Len(temp) Step 1
    DoEvents
    Winsock1.SendData (Mid(temp, a, 1))
    RaiseEvent Progression(Pos + a, max, (Fix(Pos + a) * 5) / max)
    Next a
    Pos = Pos + a
Else
    For a = 1 To Len(temp) Step 50
    DoEvents
    Winsock1.SendData (Mid(temp, a, 50))
    Vartmp = Mid(temp, a, 50)
    RaiseEvent Progression(Pos + a, max, (Fix(Pos + a) * 5) / max)
    Next a
    Pos = max
    RaiseEvent Progression(Pos, max, (Fix(Pos) * 5) / max)
End If
End Sub
Public Function PieceJointeAjout(StrPath As String)
FichierJoint = True
ReDim Preserve Fichiers(X)
Fichiers(X) = StrPath
X = X + 1
RaiseEvent FichiersJoints(X, Join(Fichiers, ","))
End Function

Public Function PieceJointeSuppr(StrPath As String)
Dim Tmp() As String, Xx As Integer
    For i = 0 To UBound(Fichiers)
        If Fichiers(i) <> StrPath Then
            ReDim Preserve Tmp(Xx)
            Tmp(Xx) = Fichiers(i)
            Xx = Xx + 1
        End If
    Next i
Erase Fichiers()
On Error GoTo Pasfichier
    For i = 0 To UBound(Tmp)
        ReDim Preserve Fichiers(i)
        Fichiers(i) = Tmp(i)
    Next i
Erase Tmp
GoTo Continue

Pasfichier:
RaiseEvent FichiersJoints(0, "")
FichierJoint = False
Exit Function

Continue:
RaiseEvent FichiersJoints(UBound(Fichiers), Join(Fichiers, ","))
End Function

Private Sub Winsock1_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
RaiseEvent Progression(max - bytesRemaining, max, 5 + (Fix(max - bytesRemaining) * 95) / max)
End Sub

Commentaire de olivierXIII le 23/10/2004 11:47:34

hum apparement la procédure uuencode ne vient pas de toi (déja c'est en anglais et le reste en fr) http://www.vbip.com/winsock/winsock_uucode_02.asp
mais bon y'a pas de mal a récupérer du code a droite a gauche.

je cite ce que le gars disait:
___________________________________
I don't claim that it's the fastest code ever. But it's the fastest one I have ever tried. Visual Basic is not very strong when deals with the strings.
___________________________________
suffit de bien se débrouiller...

Commentaire de proximad le 21/02/2005 02:43:18

salut, il est super ton programme, j'ai pu m'envoyer des emails sans prob quand je clique sur "play" , mais lorsque j'essaye de compiler j'ai l'erreur suivante:
compile error:
ByRef argument type mismatch
et on m'envoie a cette ligne du winsock
Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
RaiseEvent Reponse(Description, Scode)
tu peux m'aider?
merci

Commentaire de fkuchta le 28/02/2005 18:15:00

Félicitation pour ce code (10/10). En plus de fonctionner de manière plus que correcte, sans OCX externe, sans Outlook, sans DLL, il m'a permis de bien comprendre le fonctionnement d'un serveur SMTP et de ses commandes.

J'ai modifié ton code et ajouté quelques améliorations :
http://www.vbfrance.com/code.aspx?ID=29843

A+

Commentaire de marc660 le 06/05/2005 13:03:11

Bonjour,
voila quand je m’envoie un email ce lui si est bien dans ma boite avec increditmail, mais quand je l’envoie avec pièce (un fichier) sur increditmail j’ai bien reçu le fichier mais pas le message.

merci

Commentaire de looping_69 le 16/11/2005 08:10:26

Salut, ce code marche super bien mais comment fait on pour rsjouter des email en copie ???

Commentaire de alcania le 22/11/2005 22:43:03

10/10
Exactement ce qu'il me fallait pour mon prog.

Rien a redire, sauf peut-etre : Excelentissime.

Commentaire de bouv le 22/12/2005 10:35:15

Sympa ce code !
Je me suis permis d'apporter une petite amélioration pour récupérer les comptes SMTP déjà présents dans le PC.

Dans la form 1 ajoutez une ComboBox et nommez la cboCompte.
Puis mettez y code

Private Sub Form_Load()
    Dim i As Integer
    Call Get_Emails
    Call cboCompte.AddItem("Autre compte")
    For i = 1 To UBound(MesEmails)
        Call cboCompte.AddItem(MesEmails(i).Account_Name)
    Next i
    cboCompte.ListIndex = 0
End Sub

Private Sub cboCompte_Click()
    TxtServeur.Text = MesEmails(cboCompte.ListIndex).SMTP_Server
    TxtMailEmeteur.Text = MesEmails(cboCompte.ListIndex).SMTP_Email_Address
End Sub

Et ce code dans un module

Public MesEmails() As Compte_Email

Public Type Compte_Email
    Numero As String
    Account_Name As String
    POP3_Server As String
    POP3_User_Name As String
    SMTP_Display_Name As String
    SMTP_Email_Address As String
    SMTP_Server As String
End Type

Public Function BDR_Lire(Cle As String) As String
    On Error Resume Next
    Set WshShell = CreateObject("Wscript.Shell")
    BDR_Lire = WshShell.RegRead(Cle)
End Function

Public Sub Get_Emails()
    Dim i As Integer
    Dim iCurrent As Integer
    Const ChaineDeBase = "HKEY_CURRENT_USER\Software\Microsoft\Internet Account Manager\Accounts\0000000"

    ReDim MesEmails(0)
    'On peut faire plus que 10 mais il est rare d'avoir autant d'adresses email dans un seul PC
    For i = 1 To 10
        If Not BDR_Lire(ChaineDeBase & CStr(i) & "\SMTP Server") = "" Then
            iCurrent = UBound(MesEmails) + 1
            ReDim Preserve MesEmails(iCurrent)
            MesEmails(iCurrent).Account_Name = BDR_Lire(ChaineDeBase & CStr(i) & "\Account Name")
            MesEmails(iCurrent).Numero = "0000000" & CStr(i)
            MesEmails(iCurrent).POP3_Server = BDR_Lire(ChaineDeBase & CStr(i) & "\POP3 Server")
            MesEmails(iCurrent).POP3_User_Name = BDR_Lire(ChaineDeBase & CStr(i) & "\POP3 User Name")
            MesEmails(iCurrent).SMTP_Display_Name = BDR_Lire(ChaineDeBase & CStr(i) & "\SMTP Display Name")
            MesEmails(iCurrent).SMTP_Email_Address = BDR_Lire(ChaineDeBase & CStr(i) & "\SMTP Email Address")
            MesEmails(iCurrent).SMTP_Server = BDR_Lire(ChaineDeBase & CStr(i) & "\SMTP Server")
        End If
    Next i
End Sub

HAVE FUN !!!

10/10 Pour PCPUNCH

Commentaire de calsn le 04/07/2006 18:19:17

Bonjour,

Je poste très très peu souvent...

Effectivement... Excellent code. Beaucoup existent, peu fonctionnent.

Il n'y manque pour ma part que le fameux 'Cc:'.

Commentaire de JJDai le 28/11/2006 16:11:07

Bonjour,
Super code, que j'ai transformé pour enpyer a plusiseurs destinataires avec des pieces jointes.
Mais j'ai toute fois un probleme:
- Le message doit être envoyer en HTML. J'ai don ajouté ceci avant le message:
-----------------------------------------------------------
   sLine = "MIME-Version: 1.0" & vbCrLf _
          & "Content-Type: text/html; charset=iso-8859-1" & vbCrLf _
          & "Content-Transfer-Encoding: 8bit" & vbCrLf
--------------------------------------------------------------
Impecable le message araivent formaté en HTML par contre la piece jointe s'affiche à la suite encore encodé.
Si je ne mets pas ces lignes, la pieces jointe arrive bien et je peux l'ouvrir, mais le message n'arrive plau formaté en html mais c'est le text  qui arrive avec les balises.
J'ai tenté d'ajouter un trud du genre
---------------------------------
sLine = "Content-Type: text/plain; charset=ISO-8859-1" & vbCrLf
sLine = sLine & "Content -transfer - encoding: Base64" & vbCrLf
-----------------------------------
juste avant la piece jointe, mais reina faire, ou j'ai le message correctement formaté ou la piece jinte. Impossible d'avoir les deux.
Quelqu'uns aurait-il une solution
Merci d'avance JJDAI

Commentaire de azerty25 le 01/12/2006 11:57:09

Il y a plusieurs RFC qui traitent du formatage des emails et traduites en FR, comme la RFC 2045, 2046, 2047, que tu peux lire ici : jlr31130.free.fr

Commentaire de JJDai le 02/12/2006 19:51:39

Merci, j'y vais de ce pas.
Mais je pense avoir trouvé la cause de mon probleme. Il semble que l'encodage base64 ne soit pas pris en charge par le tag "Content-Type: mixed" il faut utiliser le "quoted-printable".
Je prépare un exemple que je mettrais sur le site.

Commentaire de jipef le 04/12/2006 17:10:11

est ce que le ZIP integre les modifs de olivierXIIIet celle de Bouv ????
ça m'interesse pour recuperer des pieces jointes et les copier dans un autre rep

a propos allez voir ce source il fait tout !!! je viens de le tester c'est fantastique mais peut etre un peu trop compliqué pour moi réutiliser
je pense que votre methode est plus simple , plus lisible

http://www.vbfrance.com/code.aspx?ID=33521
merci

Commentaire de nagstef le 15/03/2008 19:56:39 10/10

Salut !!

Je sais pas si tu es toujours sur ce programme mais je voudrais comprendre si je fais quelque chose d'incorrect ?

J'utilise ton soft donc pour envoyer 2 mails avec les mêmes paramètres (dont un fichier attaché), exceptés le destinataire !!

Lorsque j'envoies sur un hotmail.fr, pas de souci, lorsque c'est un gmail.com, le fichier n'est pas attaché, mais encodé dans le texte du message !!

Est-ce normal ?

Merci de ton aide, ou de toute autre personne :) !

Stef

Commentaire de jfburdin le 22/03/2011 21:41:29

10/10 pour le programme à part qu'un fichier attaché annule le message.
ce problème a-t-il été résolu?

Commentaire de pepere5 le 12/02/2012 11:14:11 10/10

Superbe programme qui fonctionne également avec Windows 7 à condition d'y installer l'ActiveX avec regsvr32/u/s MSWINSCK.OCX
Toutes mes félicitations.

Ajouter un commentaire

Nos sponsors

Derniers Blogs

[WP7] DYNAMICALLY CHANGE STARTUP PAGE par KooKiz

SESSION SILVERLIGHT 5 3D : SLIDES ET DEMOS par Groc

[TECHDAYS 2012] SESSION WEBMATRIX 2 : LE COUTEAU SUISSE GRATUIT POUR VOS DéVELOPPEMENTS WEB - SLIDES par gpommier

[SHAREPOINT] LES SESSIONS TECHDAYS 2012. par Patrick Guimonet

TECHDAYS PARIS 2012 : SESSION PLEINIèRE JOUR 3 par ROMELARD Fabrice

Forum

RE : LISTER KEYS.KEY par ucfoutu

RE : LISTER KEYS.KEY par Renfield

RE : RECORDSET DE VB6 à VB2010...GRRRRRRRR par Renfield

LISTER KEYS.KEY par Onin42

Côté IT

Offres d'emploi

Formations Video

Appels d'offres

Passerelle Pericles sur site Joomla 17
Budget : 499€
Infogerance Serveur Debian Linux
Budget : 2 400€
Developpeur applications iphone - ipad - android
Budget : 800€

Logiciels

Tribler (2012)
TRIBLER (2012)

Tribler est un client pair à pair (P2P/Peer-to-Peer) open source avec la capacité de regarder des...

Cliquez pour télécharger Tribler
OneSwarm (2012)
ONESWARM (2012)

Le peer-to-peer qui protège votre vie privée, c'est OneSwarm. Ce logiciel de peer-to-peer crypté...

Cliquez pour télécharger OneSwarm
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)
PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO (V8.4)

PONAMEDIA TV DEVIENS HELLLOOO FLASH LA TV SUR VOTRE ORDINATEUR. Toute une plateforme Multi...

Cliquez pour télécharger PONAMEDIA PREMIUM - HELLLOOO FLASH DEMO
Academy System (17.2.1.0)
ACADEMY SYSTEM (17.2.1.0)

Logiciel de gestion des établissements. - élèves/étudiants (inscription, dossier, absence...) -...

Cliquez pour télécharger Academy System
Easy-Planning (1.0.0.1)
EASY-PLANNING (1.0.0.1)

Basé sur les mêmes principes que MyPlanning, Easy-Planning permet de créer des plannings sous la ...

Cliquez pour télécharger Easy-Planning