envoi de email

Question

Bonjour a tous je fias presentement un projet en visual basic 6 qui doit envoyer automatiquement un email dans outlook ( sans la message de securite / autorisation de outlook ) 
J'ai reussi a le faire avec winsock et aussi avec un modulde de classe  avec win98

Mon probleme ces que dans les deux cas cela fonctionne seulement sur win98
et j'en ai de besoin pour un reseau local NT et sa ne marche pas 
J'aurais besoin d'aide pour que mon projet fonctionne sur NT  
pouvez-vous m'aider ?   svp    Merci beaucoup!

Bubar92Bubar92 · Answer

salut
pour xp et outloock express si tu veux
C.V

Bubar92Bubar92 · Answer

salut ca fonctionne mais il y a du menage a faire tu fait ce que tu veux avec soit tu t'en sert t'elle quelle ou le modifier tu voi d'autre question pas de probleme Public NamePrg As String Private Sub AdressEnvoie_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ' Dim fichier As Variant ' For Each fichier In Data.SetData(vbCFText) 'AdressEnvoie.AddItem Data ' Next End Sub Private Sub AdressGen_Click() AdressEnvoie.AddItem AdressGen.List(AdressGen.ListIndex) End Sub Sub CheminAjoutBar(ch) If Right(ch, 1) <> "" Then ch = ch & "" End Sub Sub Sauvegarde() s = "Chemin et Nom" SaveSetting appname:=NamePrg, section:=s, Key:="Chemin du fichier adresse", setting:=Text2 SaveSetting appname:=NamePrg, section:=s, Key:="Nom du fichier adresse", setting:=Text3 SaveSetting appname:=NamePrg, section:=s, Key:="Chemin du fichier parametre", setting:=Text4 SaveSetting appname:=NamePrg, section:=s, Key:="Nom du fichier parametre", setting:=Text5 s = "List Adresse general" SaveSetting appname:=NamePrg, section:=s, Key:="Nombre", setting:=AdressGen.ListCount For X = 0 To AdressGen.ListCount - 1 SaveSetting appname:=NamePrg, section:=s, Key:=X, setting:=AdressGen.List(X) Next X s = "List Adresse envoie" SaveSetting appname:=NamePrg, section:=s, Key:="Nombre", setting:=AdressEnvoie.ListCount For X = 0 To AdressEnvoie.ListCount - 1 SaveSetting appname:=NamePrg, section:=s, Key:=X, setting:=AdressEnvoie.List(X) Next X s = "Pièce jointe" SaveSetting appname:=NamePrg, section:=s, Key:="Nombre", setting:=LsPièceJointe.ListCount For X = 0 To LsPièceJointe.ListCount - 1 SaveSetting appname:=NamePrg, section:=s, Key:=X, setting:=LsPièceJointe.List(X) Next X s = "Feuille" SaveSetting appname:=NamePrg, section:=s, Key:="a partir du haut", setting:=ix.Top SaveSetting appname:=NamePrg, section:=s, Key:="a partir de gauche", setting:=ix.Left SaveSetting appname:=NamePrg, section:=s, Key:="Hauteur", setting:=ix.Height SaveSetting appname:=NamePrg, section:=s, Key:="Largeur", setting:=ix.Width SaveSetting appname:=NamePrg, section:=s, Key:="Parametre Visible", setting:=FtParametre.Visible s = "Texte" s = "Texte" SaveSetting appname:=NamePrg, section:=s, Key:="Objet", setting:=TxtSujet SaveSetting appname:=NamePrg, section:=s, Key:="Message", setting:=Corps SaveSetting appname:=NamePrg, section:=s, Key:="Nombre", setting:=Text1 SaveSetting appname:=NamePrg, section:=s, Key:="nombre de mail envoie", setting:=NbMailEnvoie SaveSetting appname:=NamePrg, section:=s, Key:="Pièce jointe", setting:=LsPièceJointe.Text SaveSetting appname:=NamePrg, section:=s, Key:="List Adresse envoie", setting:=AdressEnvoie.Text SaveSetting appname:=NamePrg, section:=s, Key:="List Adresse general", setting:=AdressGen.Text SaveSetting appname:=NamePrg, section:=s, Key:="Nombre de minute avant envoie", setting:=MnEnvoie.Text s = "Bouton" SaveSetting appname:=NamePrg, section:=s, Key:="Envoie puis END", setting:=Check1 SaveSetting appname:=NamePrg, section:=s, Key:="Sauvegarde si click sur croix", setting:=Check2 SaveSetting appname:=NamePrg, section:=s, Key:="Sauvegarde avant de quitter", setting:=Check3 SaveSetting appname:=NamePrg, section:=s, Key:="Envoie en boucle", setting:=Check4 End Sub Private Sub Form_DblClick()If FtParametre.Visible Then FtParametre.Visible False Else FtParametre.Visible True End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) If UnloadMode = 0 And Check2 Then Call Sauvegarde End Sub Private Sub Label12_Click() Call Sauvegarde End Sub Private Sub Label14_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) erreur = "erreur OLEDragDrop" On Error GoTo finLabel14 Dim fichier As Variant For Each fichier In Data.Files 'LsPièceJointe.AddItem fichier'Text3 Dir(fichier): c InStr(1, fichier, Text3) 'If c <> 0 Then ' Text2 = Left(fichier, c - 1) ' End If FileCfg = fichier Next erreur = "erreur lecture du fichier" 'Chm = "D:\DONNEES": Call CheminAjoutBar(Chm) 'nom = "adresse amie outlook.txt" 'FileCfg = Chm & nomc 1: pvx 0 b = "Adresse de messagerie" Open FileCfg For Input As #1 Do While Not EOF(1) ' Cherche la fin du fichier. lire:Line Input #1, a: a LTrim(a): NumLigne NumLigne + 1 If a = "" Then GoTo lire If Len(a) < 2 Then GoTo lire erreur = "erreur de traitement" If NumLigne = 1 Then gvsdfsd:pvx InStr(pvx + 1, a, ";"): If pvx <> 0 Then n n + 1 pc = Mid(a, pvx, Len(b) + 1) If pc <> ";" & b Then GoTo gvsdfsd GoTo lire End If 'If NumLigne = 5 Then GoTo lirenbpv n: n 0: pvx = 0 eeeeee: pvx InStr(pvx + 1, a, ";"): If pvx <> 0 Then n n + 1 Else GoTo lire If nbpv <> n Then GoTo eeeeee pvxder InStr(pvx + 1, a, ";"): If pvxder 0 Then GoTo lire l = pvx + 1 ll = pvxder - l nom = Mid(a, pvx + 1, ll) c = InStr(1, a, b) 'pc = Mid(a, c - 1, 1) If c <> 0 Then Stop AdressGen.AddItem nom erreur = "erreur lecture du fichier" 'If A = "" Then GoTo lgvide Loop: Close #1 Exit Sub finLabel14: Call SpGestionErreur(erreur) End Sub Private Sub Label15_Click() Unload Me Me.Show End Sub Private Sub Label17_Click()If FtParametre.Visible Then FtParametre.Visible False Else FtParametre.Visible True End Sub Private Sub Label18_Click() If LsPièceJointe.ListIndex <> -1 Then LsPièceJointe.RemoveItem LsPièceJointe.ListIndex End Sub Private Sub Label19_Click() AdressEnvoie.AddItem Clipboard.GetText(vbCFText) End Sub Private Sub Label19_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Label19.ToolTipText = Clipboard.GetText(vbCFText) End Sub Private Sub LsPièceJointe_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) erreur = "erreur OLEDragDrop": On Error GoTo finLsPièceJointe Dim fichier As Variant For Each fichier In Data.Files LsPièceJointe.AddItem fichier 'liste pour piece jouinte NextIf LsPièceJointe.ListCount > 1 Then sp "s" Else sp "" LsPièceJointe.Text = LsPièceJointe.ListCount & " Pièce" & sp & " jointe" & sp Exit Sub finLsPièceJointe: Call SpGestionErreur(erreur) End Sub Private Sub Form_Load() Me.PSet (300, 100), RGB(255, 0, 0) Me.PSet (10.75, 50.33), RGB(255, 0, 0) Me.PSet (230, 1000), RGB(255, 0, 0) GoTo g ' Déclare les variables. Dim CX, CY, Msg, XPos, YPos ScaleMode = 3 ' Définit pixel comme unité de ' mesure. DrawWidth = 5 ' Définit la propriété DrawWidth. ForeColor = QBColor(4) ' Définit rouge comme ' couleur de premier plan. FontSize = 24 ' Définit la taille du point. CX = ScaleWidth / 2 ' Obtient le centre horizontal CY = ScaleHeight / 2 ' Obtient le centre vertical Cls ' Efface la feuille. Msg = "Bonne année !" CurrentX = CX - TextWidth(Msg) / 2 CurrentY = CY - TextHeight(Msg) ' Position ' verticale. 'Print Msg ' Imprime le message. Do ' Obtient la position horizontale. XPos = Rnd * ScaleWidth ' Obtient la position verticale. YPos = Rnd * ScaleHeight ' Dessine le confetti. PSet (XPos, YPos), QBColor(Rnd * 15) 'DoEvents ' Laisse s'effectuer d'autres Loop ' traitements. g: NamePrg = "Envoie de Mail"c "d:": ChmDefaut CurDir() 'ShellExecute Me.hwnd, "Open", "[mailto:?Subject mailto:?Subject]=" & TxtSujet.Text, vbNullString, vbNullString, vbNormalFocus 'Dim myolapp As Outlook.Application 'Dim myitem As Outlook.MailItem s = "Chemin et Nom" yy = GetSetting(appname:=NamePrg, section:=s, Key:="Chemin du fichier adresse"): If yy <> "" Then Text2 = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Nom du fichier adresse"): If yy <> "" Then Text3 = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Chemin du fichier parametre"): If yy <> "" Then Text4 = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Nom du fichier parametre"): If yy <> "" Then Text5 = yy s = "List Adresse general" If GetSetting(appname:=NamePrg, section:=s, Key:="Nombre") <> "" Then yy = GetSetting(appname:=NamePrg, section:=s, Key:="Nombre") - 1 For X = 0 To yy AdressGen.AddItem GetSetting(appname:=NamePrg, section:=s, Key:=X) Next X End If s = "List Adresse envoie" If GetSetting(appname:=NamePrg, section:=s, Key:="Nombre") <> "" Then yy = GetSetting(appname:=NamePrg, section:=s, Key:="Nombre") - 1 For X = 0 To yy AdressEnvoie.AddItem GetSetting(appname:=NamePrg, section:=s, Key:=X) Next X End If s = "Texte" yy = GetSetting(appname:=NamePrg, section:=s, Key:="Objet"): If yy <> "" Then TxtSujet = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Message"): If yy <> "" Then Corps = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Nombre"): If yy <> "" Then Text1 = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="nombre de mail envoie"): If yy <> "" Then NbMailEnvoie = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Pièce jointe"): If yy <> "" Then LsPièceJointe.Text = yy ': Stop yy = GetSetting(appname:=NamePrg, section:=s, Key:="List Adresse envoie"): If yy <> "" Then AdressEnvoie.Text = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="List Adresse general"): If yy <> "" Then AdressGen.Text = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Nombre de minute avant envoie"): If yy <> "" Then MnEnvoie.Text = yy s = "Pièce jointe" If GetSetting(appname:=NamePrg, section:=s, Key:="Nombre") <> "" Then yy = GetSetting(appname:=NamePrg, section:=s, Key:="Nombre") - 1 For X = 0 To yy LsPièceJointe.AddItem GetSetting(appname:=NamePrg, section:=s, Key:=X) Next X End If s = "Feuille" yy = GetSetting(appname:=NamePrg, section:=s, Key:="a partir du haut"): If yy <> "" Then ix.Top = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="a partir de gauche"): If yy <> "" Then ix.Left = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Hauteur"): If yy <> "" Then ix.Height = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Largeur"): If yy <> "" Then ix.Width = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Parametre Visible"): If yy <> "" Then FtParametre.Visible = yy s = "Bouton" yy = GetSetting(appname:=NamePrg, section:=s, Key:="Envoie puis END"): If yy <> "" Then Check1 = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Sauvegarde si click sur croix"): If yy <> "" Then Check2 = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Sauvegarde avant de quitter"): If yy <> "" Then Check3 = yy yy = GetSetting(appname:=NamePrg, section:=s, Key:="Envoie en boucle"): If yy <> "" Then Check4 = yy Chm = "d:": Call CheminAjoutBar(Chm) nom = "ad.txt" FileCfg = Chm & nom If nom = "" Then GoTo ExitSub If FileCfg = "" Then GoTo ExitSub FileExit = Dir(FileCfg) If nom <> FileExit Then GoTo ExitSub Open FileCfg For Input As #1 Do While Not EOF(1) ' Cherche la fin du fichier. Line Input #1, a: a = LTrim(a) If a = "" Then GoTo lgvide 'AdressGen.AddItem a lgvide: Loop: Close #1 'Dim str As String 'Dim msn As VbMsgBoxResult 'Dim Adresse As String 'Dim Corps As String 'Corps = "essai" If MnEnvoie <> "" Then If MnEnvoie <> "" And MnEnvoie <> 0 Then MnAvantEnvoie MnEnvoie: Timer1.Interval 1000: Call SpEnvoie End If ExitSub: 'Exit Sub End Sub Private Sub Label1_Click() 'MAPISession1.SignOn erreur = "erreur lecture carnet d'adresse" 'On Error GoTo finLabel1 ' With MAPIMessages1 ' .Show '.AddressLabel 'MAPISession1.Index 'End With 'MAPISession1.SignOff erreur = "erreur d'adresse" ad = MAPIMessages1.AddressLabel a = MAPIMessages1.AddressCaption a1 = MAPIMessages1.AddressResolveUI a2 = MAPIMessages1.RecipAddress a3 = MAPIMessages1.AddressEditFieldCount a4 = MAPIMessages1.AddressModifiable Set ons = MAPISession1.GetNamespace("MAPI") Set fl = ons.Folders("Dossiers publics") Set fl = fl.Folders("Tous les dossiers publics") Set fl = fl.Folders("Contacts Listes") For i = 1 To fl.Items.Count Set r = ons.CreateRecipient("Dupond") 'Dupond étant un contact existant dans les contacts d'un dossier public r.Resolve If r.Resolved Then MsgBox "ok" fl.Items.Item(i).AddMember r 'fl.Items.Item(i).Display fl.Items.Item(i).Save Next Exit Sub finLabel1: Call SpGestionErreur(erreur) End Sub Private Sub Label5_Click() Call SpEnvoie End Sub Sub SpEnvoie() Dim i As Integer EnvoieEnBoucle: For adressX = 0 To AdressEnvoie.ListCount - 1 'list adresse erreur = "erreur nombre de mail incorect" On Error GoTo finLabel5 For X = 1 To Text1 'nombre d'envoie erreur = "erreur divers" AdressEnvoie.Text = AdressEnvoie.List(adressX): AdressEnvoie.Refresh Label10 = X: Label10.Refresh Label16 = adressX + 1: Label16.Refresh MAPISession1.SignOn With MAPIMessages1 .MsgIndex = -1 .RecipAddress = AdressEnvoie.List(adressX) ' ici l adresse e-mail du destinataire .MsgSubject = TxtSujet.Text ' ici le sujet du mail" .MsgNoteText = Corps.Text ' ici le message du mail For i = 0 To LsPièceJointe.ListCount - 1 .AttachmentIndex = i 'le numéro d'index correspond au nombre supplémentaire de pièces jointes .AttachmentPathName = LsPièceJointe.List(i) 'ici la pièce jointe supplémentaire Next i .SessionID = MAPISession1.SessionID .Send 'Envoie un message. End With NbMailEnvoie = NbMailEnvoie + 1 MAPISession1.SignOff On Error GoTo fin Next X 'nombre d'envoie Next adressX 'list adresse fin: If Check4 Then GoTo EnvoieEnBoucle Select Case MnEnvoie Case "", "0" If Check1 Then 'quitter apres envoie If Check3 Then Call Sauvegarde 'Sauvegarde avant de quitter Unload Me End End If End Select Exit Sub finLabel5: Call SpGestionErreur(erreur) End Sub Private Sub Label8_Click() AdressGen.AddItem AdressGen.Text End Sub Private Sub Label9_Click() If AdressEnvoie.ListIndex <> -1 Then AdressEnvoie.RemoveItem AdressEnvoie.ListIndex End Sub Private Sub Label9_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Label9.ToolTipText = AdressEnvoie.List(AdressEnvoie.ListIndex) End Sub Private Sub MnEnvoie_Change()'If MnEnvoie "" Then Timer1.Enabled False Else Timer1.Enabled = True 'If MnEnvoie = 0 Then Select Case MnEnvoieCase "", "0": MnAvantEnvoie "": Timer1.Enabled FalseCase Else: MnAvantEnvoie MnEnvoie: Timer1.Enabled True End Select End Sub Private Sub t_Timer() 's.BackColor = RGB(255, 0, 0) End Sub Private Sub Text2_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Dim fichier As Variant For Each fichier In Data.Files LsPièceJointe.AddItem fichier Text3 Dir(fichier): c InStr(1, fichier, Text3) If c <> 0 Then Text2 = Left(fichier, c - 1) End If Next End Sub Private Sub Text4_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Dim fichier As Variant For Each fichier In Data.Files LsPièceJointe.AddItem fichierText5 Dir(fichier): c InStr(1, fichier, Text5) If c <> 0 Then Text4 = Left(fichier, c - 1) End If Next End Sub Sub SpGestionErreur(erreur) e = erreur & vbCrLf & Err.Description & " num " & Err.Number r = MsgBox(e, vbCritical, "E R R E U R") End Sub Private Sub Timer1_Timer()If Second(Time) 0 Then MnAvantEnvoie MnAvantEnvoie - 1If MnAvantEnvoie <0 Then MnAvantEnvoie MnEnvoie: Call SpEnvoie End Sub C.V

Envoi de email

2 réponses

Discussions similaires