Sujet Précédent Sujet Suivant

Joindre une pièce jointe à un email avec Winsok

basamir Messages postés 335 Date d'inscription vendredi 21 octobre 2005 Statut Membre Dernière intervention 8 mars 2008 - 13 janv. 2008 à 15:43
cs_Jack Messages postés 14006 Date d'inscription samedi 29 décembre 2001 Statut Modérateur Dernière intervention 28 août 2015 - 15 janv. 2008 à 05:52
Bonjour,

je viens de recuperer un code de vbfrance qui permet d'envoyer des emails grace à winsok et qui marche avec quelques smtp uniquement, j'ai cherché à joindre une pièce jointe et j'ai adapté un code de vbfrance aussi mais il n y a aucune pièce jointe lors de la réception de l'email, voici le code avec le module de jointure:
Code:
Dim Etape As Integer
Dim Erreur As Boolean

Private Sub Command1_Click()
piece_jointe.Show
End Sub

Private Sub Command2_Click()
    Dim Ret
    Dim temp As Retour
    Erreur = False
    MousePointer = fmMousePointerAppStarting
    temp = Vérification_Champs
    If temp.valeur = False Then     'Erreur
        Ret = MsgBox(temp.libelle, vbCritical, "Erreur")
        MousePointer = fmMousePointerDefault
    Else                            'On met en forme les données
        Etape = 0
        If Not W.State = 0 Then W.Close
        DoEvents
       'prepare les fichiers joints'
        For i = 0 To piece_jointe.lstAttachments.ListCount - 1
        piece_jointe.lstAttachments.ListIndex = i
        m_strEncodedFiles = m_strEncodedFiles & _
                         UUEncodeFile(piece_jointe.lstAttachments.Text) & vbCrLf
        Next i
        W.RemoteHost = Text_Serveur.Text
        W.Connect
    End If

   
End Sub

Private Sub ferm_Click()
Unload Me
End Sub

Private Sub Form_Load()
Join.Visible = False
Label2.Visible = False
    W.RemotePort = 25
    'W.LocalPort = 1003
    W.LocalPort = 0
    Bar.max = 60
End Sub

Private Sub Form_Unload(Cancel As Integer)
If Form1.Command14.Visible = True Then
Form1.Command14.Visible = False
Form1.Command12.Visible = True
'Form1.Command12.Value = True
Form1.raff_aff.Enabled = False
Form1.acti_aff.Enabled = True
Form1.Adodc1.Visible = True
Form1.DataGrid1.Visible = True
Unload Me
Else
Unload Me
End If
End Sub

Private Sub W_DataArrival(ByVal bytesTotal As Long)
    Dim Temp_Recep, Temp_Envoi As String
    Dim Ret
   
    W.GetData Temp_Recep, vbString
    Select Case Etape
    Case 0
        If Recup(Temp_Recep, 220) Then
            '''''''''''' Recup du nom du serveur pour la commande "HELO {Nom du serveur}"
            Temp_Envoi = "HELO " & Text_Serveur
            Envoyer (Temp_Envoi)
        Else
            MsgBox ("Problème lors de la Connexion" & vbCrLf & Temp_Recep)
            MousePointer = fmMousePointerDefault
        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: " & "<" & Text_Mail_Emet & ">"
            Envoyer (Temp_Envoi)
        Else
            '''''''''''' Le HELO est rejeté
            MsgBox ("Problème lors de la réponse au HELO" & vbCrLf & Temp_Recep)
            MousePointer = fmMousePointerDefault
        End If
    Case 2
        If Recup(Temp_Recep, 250) Then
            '''''''''''' Le MAIL FROM: est accepté
            Temp_Envoi = "RCPT TO: " & "<" & Text_Mail_Dest & ">"
            Envoyer (Temp_Envoi)
        Else
            '''''''''''' Le MAIL FROM: n'est pas accepté
            MsgBox ("Problème lors de la réponse au MAIL FROM" & vbCrLf & Temp_Recep)
            MousePointer = fmMousePointerDefault
        End If
    Case 3
        If Recup(Temp_Recep, 250) Then
            '''''''''''' Le RCPT est accepté, on a fait le plus dur ;)
            Temp_Envoi = "DATA"
            Envoyer (Temp_Envoi)
        Else
            '''''''''''' Le serveur n'est pas open relay ou alors le destinataire est inconnu
            MsgBox ("Problème lors de la réponse au RCPT TO" & vbCrLf & Temp_Recep)
            MousePointer = fmMousePointerDefault
        End If
    Case 4
        If Recup(Temp_Recep, 354) Then
            Temp_Envoi = ""
            '''''''''''' Remplir les champs correspondant à l'emetteur            If Not Text_Nom_Emet "" Or Not Text_Mail_Emet "" Then
                Temp_Envoi = "From: "                If Not Text_Nom_Emet "" Then Temp_Envoi Temp_Envoi & Chr(34) & Text_Nom_Emet & Chr(34) & " "                If Not Text_Mail_Emet "" Then Temp_Envoi Temp_Envoi & "<" & Text_Mail_Emet & ">"
                Temp_Envoi = Temp_Envoi & vbCrLf
            End If
           
            ''''''''''' Remplir les champs correspondant au destinataire
            Temp_Envoi = Temp_Envoi & "To: "            If Not Text_Nom_Dest "" Then Temp_Envoi Temp_Envoi & Chr(34) & Text_Nom_Dest & Chr(34) & " "
            Temp_Envoi = Temp_Envoi & "<" & Text_Mail_Dest & ">" & vbCrLf
           
            ''''''''''' Ajouter le sujet du mail
            Temp_Envoi = Temp_Envoi & "Subject: " & Text_Sujet & vbCrLf & vbCrLf '2 sauts de lignes pour dire que l'on passe au corps du msg
           
            ''''''''''' Ajouter le corps du message
            Temp_Envoi = Temp_Envoi & Text_Msg & vbCrLf & "."
            ''''''''''' Ajouter les pièces jointes du message
            Temp_Envoi = Temp_Envoi & m_strEncodedFiles & vbCrLf & "."
            ''''''''''' On Envoie tout
            Envoyer (Temp_Envoi)
        Else
            MsgBox ("Problème lors de la réponse au DATA" & vbCrLf & Temp_Recep)
            MousePointer = fmMousePointerDefault
        End If
        Case 5
               
            If Not Recup(Temp_Recep, 250) Then
                ''''''' Si pb lors de la fin du message
                MsgBox ("Problème lors de la fin du corps du message" & vbCrLf & Temp_Recep)
                MousePointer = fmMousePointerDefault
            Else
                ''''''' Le message a bien été envoyé ;) C po cool ca?
            End If
                Envoyer ("QUIT")
        Case 6
            If Recup(Temp_Recep, 221) Then
                If Not Erreur Then Ret = MsgBox("Le message est bien envoyé" & vbCrLf & "avec réussite." & vbCrLf & "E-mail @nonyme ;)", vbInformation, "Fin")
            Else
                MsgBox ("Problème lors de la déconnexion du serveur" & vbCrLf & Temp_Recep)
            End If
            Etape = -1
            W.Close
            MousePointer = fmMousePointerDefault
    End Select
    Etape = Etape + 1
End Sub

Private Sub W_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)
    MsgBox (Description)
    If W.State = 7 Then
        ''''''' Pour pas avoir le message MErci pour ce gentil prog....
        Erreur = True
        Envoyer ("quit")
        DoEvents
        Etape = 6
    Else
        W.Close
    End If
    MousePointer = fmMousePointerDefault
End Sub

Public Function Envoyer(temp As String)
Dim i, max, max_bar, comp_bar, delta_bar
''''''''''' on envoi les lettres une à une et en mm temps on fait progresser la barre1
max = Len(temp)
Bar.Value = Etape * 10
delta_bar = 10 / Len(temp)
For i = 1 To max Step 1
    W.SendData (Mid(temp, i, 1))
    Bar.Value = Bar.Value + delta_bar
Next i
W.SendData (vbCrLf)
End Function

----------------------------------------------------------------------------
----------------Module MUUEncode--------------------------------------

Public 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 + vbLf
    '
    'Get file size
    lFileSize = FileLen(strFilePath)
    lEncodedLines = lFileSize \ 45 + 1
    '
    'Prepare buffer to retrieve data from
    'the file by 45 symbols chunks
    strFileData = Space(45)
    '
    intFile = FreeFile
    '
    Open strFilePath For Binary As intFile
        For i = 1 To lEncodedLines
            '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 = 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
                'Breake each 3 (8-bits) bytes to 4 (6-bits) bytes
                '
                '1 byte
                strTempLine = strTempLine + Chr(Asc(Mid(strFileData, j, 1)) \ 4 + 32)
                '2 byte
                strTempLine = strTempLine + Chr((Asc(Mid(strFileData, j, 1)) Mod 4) * 16 _
                               + Asc(Mid(strFileData, j + 1, 1)) \ 16 + 32)
                '3 byte
                strTempLine = strTempLine + Chr((Asc(Mid(strFileData, j + 1, 1)) Mod 16) * 4 _
                               + Asc(Mid(strFileData, j + 2, 1)) \ 64 + 32)
                '4 byte
                strTempLine = strTempLine + Chr(Asc(Mid(strFileData, j + 2, 1)) Mod 64 + 32)
            Next j
            'replace " " with "`"
            strTempLine = Replace(strTempLine, " ", "`")
            'add encoded line to result buffer
            strResult = strResult + strTempLine + vbLf
            'reset line buffer
            strTempLine = ""
        Next i
    Close intFile

    'add the end marker
    strResult = strResult & "`" & vbLf + "end" + vbLf
    'asign return value
    UUEncodeFile = strResult
   
End Function

Le savoir est la lumière de nous tous, partageons le!

1 réponse

Réponse 1 / 1
cs_Jack Messages postés 14006 Date d'inscription samedi 29 décembre 2001 Statut Modérateur Dernière intervention 28 août 2015 79
15 janv. 2008 à 05:52
Salut
A priori, si la technique d'envoi de fichier est bonne (je ne connais pas la structure d'un mail avec pj), ça devrait fonctionné, je n'ai rien vu d'abhérent.
On n'a pas la fonction Recup, mais je suppose qu'elle fonctionne.
Le problème est-il dans l'émission ?
As-tu suivi pas à pas (avec F9/F8) un envoi ?
Est-ce que tes étapes avancent normalement ?

Juste un truc bien lourd pour pas grand chose : La fonction Envoyer qui peut se simplifier, inutile de vouloir expédier caractère par caractère (je ne pense pas que celà ait une influence)
   Public Function Envoyer(temp As String)
      Dim i, <strike>max</strike>, <strike>max_bar</strike>, <strike>comp_bar</strike>, <strike>delta_bar</strike>
      ''''''''''' on envoi les lettres une à une et en mm temps on fait progresser la barre1
      Bar.Value = Etape * 10
      Bar.Value = Bar.Value + (10 / Len(temp))
      W.SendData temp & vbCrLf
   End Function

D'autre part, fait attention de ne pas trop envoyer de vbCrLf car dans certains protocoles, un double vbCrLf signifie la fin d'envoi.
Côté réception, essaye de voir et d'identifier ce que tu reçois (*) et voir quelles sont les infos qui sont passées et celles qui ont été perdues.
(*) Dans Outlook, il faut demander à :
- clic-droit "afficher la source" dans le corps du mail si le mail est en html
- clic-droit "Options" sur l'entête du mail dans la boite de réception s'il est au format texte

Dernier conseils :
- Utilise "Option Explicit" = déclaration obligatoire des variables : C'est chiant de déclarer chaque variable, mais ça fait gagner du temps en debug et ça permet d'être rigoureux
- Lance ton appli avec Ctrl-F5 et pas F5 seul afin de découvrir les erreurs avant de tomber dessus
- Utilise la palette d'outils de MzTools (dispo ici) qui te permettra, par exemple, de lister toutes les variables qui ne servent à rien (et qui encombrent le code)

Vala
Jack, MVP VB
NB : Je ne répondrai pas aux messages privés

<hr />Le savoir est la seule matière qui s'accroit quand on la partage (Socrate)
0

Discussions similaires

winsok
mathieu57100 -
mathieu57100 -

2 réponses
Rejoignez-nous