Newsgroup: it.comp.lang.visual-basic
Titolo: [!] Invio Allegati via OE (lunghetto)

Come ho già sottolineato pochi giorni fa, usando la sola mailto:
è impossibile far inviare allegati da OE (qualcuno dice di esserci
riuscito, ma devo ancora vedere codice che lo faccia senza usare mapi).
Visto che è argomento "quasi FAQ", basandomi su un'idea di
Bruno Paris, che cito nel progetto, ho steso questo semplice
modulo bas che invia mail ed allegati _solo formato testo_
usando l'escamotage di scrivere direttamente il file eml e aprirlo
con OE.
Prossimamente conto di lavorare un po' sull'encoding Base64
e trasformarlo in un modulino multi-purpose (quindi con allegati di
qualsiasi natura) da inviare al Sc.
Per intanto... accontantatevi.   ;-PPP
ciao
ugo
p.s. allego il modulo bas e qualche riga di codice di test da incollare in
un frm
***************** modulo bas ************************************
Option Explicit
' API declarations
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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
Private Const SW_SHOWNORMAL = 1
'
Private Const bnd = "_NextPart_001_"     ' boundary
Private Const charset = "iso-8859-1"     ' charset
'---------------------------------------------------------------------------
------------
' Procedure : SendMail
' DateTime  : 02/12/2002 06.49
' Author    : Ugo - Basato su un'idea e un progetto di Bruno Paris, ameba
@
zg.tel.hr
' Purpose   : Crea una email usando il mailer default installato
' Parameters: sRecips As String,                    - Destinatari
'             sCc As String, sBcc As String,        - Destinatari in copia
'             sSubject As String, sBody As String,  - Oggetto e Testo
'             bSend As Boolean,                     - Flag inoltro immediato
'             nType As Integer,                     - Tipo testo 1=plain
text 2= html
'             aAttachTexts() As String,             - Array testi allegati
'             Optional aAttachNames As Variant      - opz. Array Nomi
Allegati
'---------------------------------------------------------------------------
------------
Public Function SendMail(sRecips As String, sCc As String, sBcc As String, _
                    sSubject As String, sBody As String, _
                    bSend As Boolean, nType As Integer, _
                    aAttachTexts() As String, Optional aAttachNames As
Variant) As Long
    Dim lNumFile As Long, sFileName As String
    Dim nAttachments As Long, nAttachNames As Long, sAttachName As String
    Dim nn As Long, nTot As Long
    Dim sMailTo As String, sType As String
    On Error GoTo SendErr
    Screen.MousePointer = vbHourglass
    DoEvents
    ' Tipo: 1=text/plain 2=text/html
    If nType = 2 Then
        sType = "text/html"
    Else
        sType = "text/plain"
    End If
    ' Recipients etc...
    sMailTo = "MAILTO:"
    If sRecips <> vbNullString Then
        sMailTo = sMailTo & sRecips
    End If
    If sCc <> vbNullString Then
        sMailTo = sMailTo & "?CC=" & sCc
    End If
    If sBcc <> vbNullString Then
        sMailTo = sMailTo & "?BCC=" & sBcc
    End If
    ' Do la precedenza all'array dei testi:
    ' i nomi se non presenti sono creati in automatico
    nAttachments = UboundArray(aAttachTexts) + 1
    If nAttachments = 0 And nType = 1 Then
        ' Se non ci sono allegati, inutile gestirlo come file...
        If Len(Trim(sSubject)) > 0 Then
            sMailTo = sMailTo & "&Subject=" & Text4Mail(sSubject)
        End If
        If Len(Trim(sBody)) > 0 Then
            sMailTo = sMailTo & "&Body=" & Text4Mail(sBody)
        End If
        SendMail = ShellExecute(1, "Open", sMailTo, "", "c:\",
SW_SHOWNORMAL)
    Else
        ' Se con allegati o html scrivo il file eml
        If Not IsMissing(aAttachNames) Then
            nAttachNames = UboundArray(aAttachNames) + 1
        Else
            nAttachNames = 0
        End If
        ' Creazione file eml
        lNumFile = FreeFile
        sFileName = GetAppPath() & "~temp.eml"
        Open sFileName For Output As #lNumFile
        ' Recipients
        Print #lNumFile, "To: " & sRecips
        ' "Carbon Copy"
        If Len(Trim(sCc)) > 0 Then
            Print #lNumFile, "Cc: " & sCc
        End If
        ' "Blind carbon copy"
        If Len(Trim(sBcc)) > 0 Then
            Print #lNumFile, "Bcc: " & sBcc
        End If
        ' subject
        Print #lNumFile, "Subject: " & sSubject
        '------------------------------------------------
        Print #lNumFile, "MIME-Version: 1.0" & vbCrLf & "Content-Type:
multipart/mixed;"
        Print #lNumFile, vbTab & "boundary=""" & bnd & """"
        Print #lNumFile, "X-Unsent: 1"
        Print #lNumFile,
        Print #lNumFile,
        Print #lNumFile, "--" & bnd
        Print #lNumFile, "Content-Type: " & sType & ";"
        Print #lNumFile, vbTab & "charset=""" & charset & """"
        Print #lNumFile, "Content-Transfer-Encoding: 7bit"
        Print #lNumFile,
        ' Body
        Print #lNumFile, sBody
        ' Allegati:
        ' Plain text file, max 60 chars per line
        For nn = 1 To nAttachments
            sAttachName = "Allegato" & Trim(Str(nn))
            If nn <= nAttachNames Then
                If aAttachNames(nn - 1) <> "" Then
                    sAttachName = aAttachNames(nn - 1)
                End If
            End If
            Print #lNumFile, "--" & bnd
            Print #lNumFile, "Content-Type: text/plain;"
            Print #lNumFile, vbTab & "name=""" & sAttachName & """"
            Print #lNumFile, "Content-Transfer-Encoding: 7bit"
            Print #lNumFile, "Content-Disposition: attachment;"
            Print #lNumFile, vbTab & "filename=""" & sAttachName & """"
            Print #lNumFile,
            Print #lNumFile, aAttachTexts(nn - 1)
        Next nn
        '------------------------------------------------
        Print #lNumFile, "--" & bnd & "--"
        ' close file temporaneo
        Close #lNumFile
        Reset ' flush file buffers
        ' wait 1-2 seconds
        For nn = 1 To 10
            Sleep (100)
            DoEvents
        Next
        '------------------------------------------------
        ' now, open created file with default e-mail program
        SendMail = ShellExecute(1, "Open", _
           sFileName, _
           "", "c:\", SW_SHOWNORMAL)
        ' if default e-mail program is Outlook Express,
        ' this will show "New Message" window
        '------------------------------------------------
        DoEvents
        Sleep (200)
    End If
    On Error Resume Next
    nn = 0
rtr:
    nn = nn + 1
    DoEvents
    Sleep (100)
    ' set focus to "Outlook Express" window with new msg
    AppActivate sSubject
    If err.Number <> 0 Then
        err.Number = 0
        ' if set focus was not succesfull, wait a while and retry
        If nn < 100 Then GoTo rtr
    Else
        ' now, press Ctrl-Enter to send to outbox
        If bSend Then SendKeys "^~"
    End If
    ' After mail is in Outbox, we might want to connect if needed:
    '    If IsConnected() = False Then
    '        StartConnection
    '    End If
    Screen.MousePointer = vbNormal
    Exit Function
SendErr:
    Screen.MousePointer = vbNormal
    ShowErrMsg
    Exit Function
End Function
'---------------------------------------------------------------------------
------------
' Procedure : Text4Mail
' Purpose   : Sostituisce in un testo le punteggiature con i codici Ascii
corrispondenti
'---------------------------------------------------------------------------
------------
Private Function Text4Mail(sOriginalText As String) As String
    On Error GoTo err
    Text4Mail = (Trim(sOriginalText))
    Text4Mail = Replace(Text4Mail, " ", "%20")
    Text4Mail = Replace(Text4Mail, vbCrLf, "%0D%0A")
    Text4Mail = Replace(Text4Mail, ",", "%2C")
    Text4Mail = Replace(Text4Mail, ".", "%2E")
    Text4Mail = Replace(Text4Mail, "?", "%3F")
    Text4Mail = Replace(Text4Mail, "!", "%21")
    Text4Mail = Replace(Text4Mail, ":", "%3A")
    Text4Mail = Replace(Text4Mail, ";", "%3B")
    Exit Function
err:
    ShowErrMsg
End Function
'---------------------------------------------------------------------------
------------
' Procedure : UboundArray
' Purpose   : Restituisce la dimensione di un array (-1 se l'array è vuoto)
'---------------------------------------------------------------------------
------------
Private Function UboundArray(TestArray As Variant) As Long
    On Error GoTo ErrorHandler
    UboundArray = UBound(TestArray)
    Exit Function
ErrorHandler:
    If err.Number = 9 Then
        UboundArray = -1
        Exit Function
    Else
        ShowErrMsg
    End If
End Function
'---------------------------------------------------------------------------
------------
' Procedure : GetAppPath
' Purpose   : Restituisce il Path dell'applicazione completo di "\" finale
'---------------------------------------------------------------------------
------------
Private Function GetAppPath() As String
   Dim sTemp As String
   sTemp = App.Path
   If Right$(sTemp, 1) <> "\" Then sTemp = sTemp & "\"
   GetAppPath = sTemp
End Function
'---------------------------------------------------------------------------
------------
' Procedure : ShowErrMsg
' Purpose   : crea un MsgBox per l'errore.
'---------------------------------------------------------------------------
------------
Public Sub ShowErrMsg()
  Screen.MousePointer = vbDefault
  MsgBox "Errore " & err.Number & ": " & err.Description & vbCrLf,
vbCritical + vbOKOnly, Screen.ActiveForm.Caption
End Sub
************** fine modulo bas ********************
************** frm di test: inserire un array di 3 command1
***********************
Private Sub Command1_Click(Index As Integer)
    Select Case Index
        Case 0
            WithoutAttach
        Case 1
            WithAttach
        Case 2
            WithHTML
    End Select
End Sub
Private Sub WithoutAttach()
    Dim sRec As String, sCc As String, sBcc As String
    Dim sSubj As String, sBody As String
    Dim aAttT() As String
    sRec = "
pi...@pluto.com
;
pl...@pluto.com
"
    sCc = "
min...@tipolino.it
"
    sBcc = "
pape...@paperino.it
,
pape...@paperino.it
;
pape...@paperino.it
"
    sSubj = "prova mail pippo"
    sBody = "riga1:" & vbCrLf & "riga2;" & vbCrLf & vbCrLf & "riga4!?.,"
    SendMail sRec, sCc, sBcc, sSubj, sBody, False, 1, _
            aAttT, aAttN
End Sub
Private Sub WithAttach()
    Dim sRec As String, sCc As String, sBcc As String
    Dim sSubj As String, sBody As String
    Dim aAttT(2) As String
    Dim aAttN(1) As String
    aAttT(0) = "prova1" & vbCrLf & "prova1 riga2"
    aAttT(1) = "prova2" & vbCrLf & "prova2 riga2"
    aAttT(2) = "prova3" & vbCrLf & "prova3 riga2"
    aAttN(0) = "prova1"
    aAttN(1) = "prova2"
    sRec = "
pi...@pluto.com
;
pl...@pluto.com
"
    sCc = "
min...@tipolino.it
"
    sBcc = "
pape...@paperino.it
,
pape...@paperino.it
;
pape...@paperino.it
"
    sSubj = "prova mail pippo con allegati"
    sBody = "riga1:" & vbCrLf & "riga2;" & vbCrLf & vbCrLf & "riga4!?.,"
    SendMail sRec, sCc, sBcc, sSubj, sBody, False, 1, _
            aAttT, aAttN
End Sub
Private Sub WithHTML()
    Dim sRec As String, sCc As String, sBcc As String
    Dim sSubj As String, sBody As String
    Dim aAttT(2) As String
    Dim aAttN(1) As String
    aAttT(0) = "prova1" & vbCrLf & "prova1 riga2"
    aAttT(1) = "prova2" & vbCrLf & "prova2 riga2"
    aAttT(2) = "prova3" & vbCrLf & "prova3 riga2"
    aAttN(0) = "prova1"
    aAttN(1) = "prova2"
    sRec = "
pi...@pluto.com
;
pl...@pluto.com
"
    sCc = "
min...@tipolino.it
"
    sBcc = "
pape...@paperino.it
,
pape...@paperino.it
;
pape...@paperino.it
"
    sSubj = "prova mail pippo con allegati - testo HTML"
    sBody = "<FONT face=Arial
size=4>riga1:<BR>riga2;<BR><BR>riga4!?.,</FONT></BODY>"
    SendMail sRec, sCc, sBcc, sSubj, sBody, False, 2, _
            aAttT, aAttN
End Sub
************************ fine frm di test ***************************

                     aAttachNames As
Per quale motivo non passi i parametri per valore?
Ciao.
-- 
BSD is for UNIX lovers -- linux is for Windows haters.


codice buttato giů la sera...   ;-P
ciao
ugo