Dim StrIn As String, percorso As String, cont1 As Long, cont2 As Long, tip As Byte, reg As String
Dim OKToSend As Boolean
Dim strdata As String, pos As Long, versione As String
Private Sub attcomand_Click()
Dialog.ShowOpen
If Dialog.FileName <> "" And Dir(Dialog.FileName) <> "" Then
TxtLogo.Text = Dialog.FileName
Else
MsgBox "Non hai selezionato nessun file, riprovare!", vbExclamation, App.Title
TxtLogo.Text = ""
Dialog.FileName = ""
Exit Sub
End If
End Sub
Private Sub Command2_Click()
If txtSMTP.Text <> "" And Recipient.Text <> "" And txtEMail.Text <> "" And txtSender.Text <> "" And txtSubject.Text <> "" And testo.Text <> "" Then
pos = 1
Command2.Enabled = False
Load WS(1)
a% = MailTo(txtSMTP.Text, txtSubject.Text, txtSender.Text, txtEMail.Text, Recipient.Text, testo.Text, TxtLogo.Text)
Unload WS(1)
If a% <> 0 Then
MsgBox "Errore durante la spedizione della email", vbCritical, App.Title & " - Errore"
Else
Call deletetemp
MsgBox "Email inviata con successo!", vbInformation, App.Title
End If
Command2.Enabled = True
Else
MsgBox "Solo il campo " & Chr(34) & "Allegato" & Chr(34) & " e facoltativo, tutti gli altri sono obbligatori", vbExclamation, App.Title
End If
End Sub
Private Sub exp_g_Click()
tip = 1
Timer2.Enabled = True
End Sub
Private Sub exp_s_Click()
tip = 2
Timer2.Enabled = True
End Sub
Private Sub Form_Load()
cont1 = 6360
cont2 = 8280
versione = App.Major & "." & App.Minor & "." & App.Revision
Caption = App.Title & " - " & App.LegalCopyright
reg = GetSetting("GM", versione, "Heigh")
If reg <> "" Then
Me.Height = reg
Else
SaveSetting "GM", versione, "Heigh", cont1
Me.Height = cont1
End If
txtSMTP.Text = "mail.libero.it"
If Me.Height = 6360 Then
exp_g.Enabled = True
exp_s.Enabled = False
tip = 1
ElseIf Me.Height = 8280 Then
exp_g.Enabled = False
exp_s.Enabled = True
tip = 2
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim hg As Long
If Me.Height > cont1 Then
SaveSetting "GM", versione, "Heigh", cont2
Else
SaveSetting "GM", versione, "Heigh", cont1
End If
Unload Me
End
End Sub
Private Sub info_Click()
frmAbout.Show 1
End Sub
Private Sub Label6_Click()
If Dialog.FileName <> "" Then
TxtLogo.Text = ""
Dialog.FileName = ""
MsgBox "Allegato eliminato !", vbInformation, App.Title
Else
MsgBox "Non esiste nessun allegato !", vbExclamation, App.Title
End If
End Sub
Private Sub Label6_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label6.ForeColor = &HFF&
Timer1.Enabled = True
End Sub
Private Sub Recipient_GotFocus()
If Recipient.Text = "destinatario@email.it" Then Recipient.Text = ""
Recipient.BackColor = vbYellow
End Sub
Private Sub Recipient_LostFocus()
Recipient.BackColor = vbWhite
Recipient.Text = LCase$(Trim$(Recipient.Text))
End Sub
Private Sub testo_GotFocus()
testo.BackColor = vbYellow
End Sub
Private Sub testo_LostFocus()
testo.BackColor = vbWhite
End Sub
Private Sub Timer1_Timer()
If Label6.ForeColor = &HFF& Then
Label6.ForeColor = &H0&
End If
Timer1.Enabled = False
End Sub
Private Sub Timer2_Timer()
If tip = 1 Then
If Me.Height < cont2 Then
Me.Height = Me.Height + 10
Else
exp_g.Enabled = False
exp_s.Enabled = True
Timer2.Enabled = False
End If
ElseIf tip = 2 Then
If Me.Height > cont1 Then
Me.Height = Me.Height - 10
Else
exp_g.Enabled = True
exp_s.Enabled = False
Timer2.Enabled = False
End If
End If
End Sub
Private Sub txtEMail_GotFocus()
If txtEMail.Text = "tua e-mail@server.it" Then txtEMail.Text = ""
txtEMail.BackColor = vbYellow
End Sub
Private Sub txtEMail_LostFocus()
txtEMail.BackColor = vbWhite
txtEMail.Text = LCase$(Trim$(txtEMail.Text))
End Sub
Private Sub TxtLogo_GotFocus()
TxtLogo.BackColor = vbYellow
End Sub
Private Sub TxtLogo_LostFocus()
TxtLogo.BackColor = vbWhite
TxtLogo.Text = Trim$(TxtLogo.Text)
End Sub
Private Sub txtSender_GotFocus()
If txtSender.Text = "Tuo nome" Then txtSender.Text = ""
txtSender.BackColor = vbYellow
End Sub
Private Sub txtSender_LostFocus()
txtSender.BackColor = vbWhite
txtSender.Text = Trim$(txtSender.Text)
End Sub
Private Sub txtSMTP_GotFocus()
txtSMTP.BackColor = vbYellow
End Sub
Private Sub txtSMTP_LostFocus()
txtSMTP.BackColor = vbWhite
txtSMTP.Text = LCase$(Trim$(txtSMTP.Text))
End Sub
Private Sub txtSubject_GotFocus()
txtSubject.BackColor = vbYellow
End Sub
Private Sub txtSubject_LostFocus()
txtSubject.BackColor = vbWhite
txtSubject.Text = Trim$(txtSubject.Text)
End Sub
Private Sub WS_DataArrival(Index As Integer, ByVal bytesTotal As Long)
WS(1).GetData strdata, vbString
'visualizza informazioni di debug (si puo' anche eliminare)
Text1.Text = Text1.Text + strdata
Text1.SelStart = Len(Text1.Text) - 1
End Sub
Function getreply(Reply As String) As Integer
'attende una risposta dal server, terminata con CR e/o LF
t# = Timer
While Timer < t# + 5 And InStr(strdata, Chr$(13)) = 0 And InStr(strdata, Chr$(10)) = 0
DoEvents
Wend
valid = False
If InStr(strdata, Chr$(13)) Then
strdata = Left$(strdata, InStr(strdata, Chr$(13)) - 1)
valid = True
End If
If InStr(strdata, Chr$(10)) Then
strdata = Left$(strdata, InStr(strdata, Chr$(10)) - 1)
valid = True
End If
If valid Then
'se tutto OK mette la stringa di risposta nella variabile Reply
Reply = strdata
getreply = 0
Else
'dopo 5 secondi esce con errore
Reply = ""
getreply = -1
End If
End Function
Function MailTo(ByVal MailServer As String, ByVal Subject As String, ByVal senderName As String, ByVal senderEmail As String, ByVal RecipientEmail As String, ByVal msgfile As String, ByVal logoFile As String) As Integer
'esegue la spedizione del messaggio
'richiede il nome del server, il file che contiene il messaggio,
'il subject del messaggio, il nome e la email di chi invia,
'la e-mail a cui il messaggio va inviato
WS(1).Protocol = sckTCPProtocol 'inizializza WINSOCK con protocollo TCP
WS(1).Connect MailServer, 25 '(porta di default dei servizi SMTP)
Reply$ = ""
'attende connessione col server: eccezionalmente si lascia piu' tempo (8 secondi)
t# = Timer
While Timer < t# + 8 And WS(1).State <> sckConnected
DoEvents
Wend
If WS(1).State <> sckConnected Then
WS(1).Close
MsgBox "Remote Host Timeout"
MailTo = -1
Exit Function
End If
t# = Timer
While Timer < t# + 5 And InStr(strdata, Chr$(13) & Chr$(10)) = 0
DoEvents
Wend
aa% = getreply(Reply$)
If aa% Then
WS(1).Close
MailTo = -1
Exit Function
End If
strdata = ""
'il programma si 'presenta' al server inviando il proprio IP address
WS(1).SendData "HELO " & WS(1).LocalIP & Chr$(13) & Chr$(10)
aa% = getreply(Reply$)
If aa% Then
WS(1).Close
MailTo = -1
Exit Function
End If
strdata = ""
'specifica l'indirizzo da cui proviene la mail
WS(1).SendData "MAIL FROM:<" & senderEmail & ">" & Chr$(13) & Chr$(10)
Reply$ = ""
aa% = getreply(Reply$)
If aa% Then
WS(1).Close
MailTo = -1
Exit Function
End If
strdata = ""
'specifica l'indirizzo a cui inviare la mail
WS(1).SendData "RCPT TO:<" & RecipientEmail & ">" & Chr$(13) & Chr$(10)
aa% = getreply(Reply$)
If aa% Then
WS(1).Close
MailTo = -1
Exit Function
End If
strdata = ""
'specifica i dati essenziali della mail
OKToSend = False
WS(1).SendData "DATA" & Chr$(13) & Chr$(10)
'attende l'avvenuta consegna pacchetto
While OKToSend = False: DoEvents: Wend
OKToSend = False
WS(1).SendData "From: " & senderName & " <" & senderEmail & ">" & Chr$(13) & Chr$(10)
While OKToSend = False: DoEvents: Wend
OKToSend = False
WS(1).SendData "To: <" & RecipientEmail & "> " & Chr$(13) & Chr$(10)
While OKToSend = False: DoEvents: Wend
OKToSend = False
WS(1).SendData "Subject: " & Subject & Chr$(13) & Chr$(10)
While OKToSend = False: DoEvents: Wend
OKToSend = False
WS(1).SendData vbCrLf
While OKToSend = False: DoEvents: Wend
strdata = ""
'Open msgfile For Input As 10
'While EOF(10) = False
' Line Input #10, l$
' elimina eventuali linee composte solo da un punto (vedi piu' avanti)
' If l$ = "." Then l$ = "_"
OKToSend = False
WS(1).SendData msgfile & Chr$(13) & Chr$(10)
While OKToSend = False: DoEvents: Wend
' Wend
'Close 10
'invia il logo, se esiste
If logoFile <> "" Then
'crea un file temporaneo per la successiva divisione, linea per linea
UU$ = ""
uuEncodeToFile "x.uue", logoFile
Open "x.uue" For Input As 10
While EOF(10) = False
Line Input #10, l$
OKToSend = False
WS(1).SendData l$ & Chr$(13) & Chr$(10)
While OKToSend = False: DoEvents: Wend
Wend
Close 10
End If
'invia il messaggio, con alla fine una linea composta solo da un "."
WS(1).SendData Chr$(13) & Chr$(10) & "." & Chr$(13) & Chr$(10)
aa% = getreply(Reply$)
If aa% Then
WS(1).Close
MailTo = -1
Exit Function
End If
strdata = ""
WS(1).SendData "QUIT" & Str$(i) & Chr$(13) & Chr$(10)
aa% = getreply(Reply$)
WS(1).Close
MailTo = 0
End Function
Private Sub WS_SendComplete(Index As Integer)
'setta il flag di avvenuta consegna pacchetto
OKToSend = True
End Sub
Sub deletetemp()
If TxtLogo.Text <> "" Then
Dim dirp As String, dir1 As String, dir2 As String, dir3 As Long, dir4 As Long, dir5 As Long, dirf As String, filetemp As String
dirp = TxtLogo.Text
dir1 = Right$(dirp, pos)
dir2 = Left$(dir1, 1)
If dir2 = "\" Then
dir3 = Len(dir1) - 1
dir4 = Len(dirp)
dir5 = dir4 - dir3
dirf = Left$(dirp, dir5)
filetemp = dirf & "x.uue"
If Dir(filetemp) <> "" Then
Kill filetemp
End If
Else
pos = pos + 1
Call deletetemp
End If
End If
End Sub
