Emailen vanuit excel

Status
Niet open voor verdere reacties.
Z

ZZ1

Gebruiker
Lid geworden
21 jul 2009
Berichten
116
Hallo,

Ik heb op dit moment een excel bestand wat dmv button automatisch wordt verstuurd maar telkens als je op verzenden klikt wordt door outlook gevraagd als je dit wilt versturen. Dat popup scherm wil ik eruit halen en op www.wimgielis.be staat een voorbeeld hiervoor maar zo wordt hij verstuurd als bijlage en ik wil een deel van een excel bestand versturen. Zie in bijgevoegd bestand hoe er nu mee wordt gewerkt..

Maar hoe krijg ik de code van Wim zo aangepast dat er een deel wordt gecopieerd en geplakt wordt in een email en automatisch verstuurd wordt. Zie volgende code & toegevoegd bestandje:
Code: 
Option Explicit

Const sDOUBLE_QUOTE As String = """"
Const sMSG_STOP_EXECUTION As String = vbNewLine & vbNewLine & "The code stops here."
Const sMSG_ERROR_ALERT As String = "Error alert"
Const sMSG_ERROR_BUTTON As String = vbCritical    'vbExclamation

'  _________________________________________________________________________________
' |                                                                                 |
' |  Wim Gielis                                                                     |
' |  wimmekegielis@hotmail.com                                                      |
' |  02/24/2009                                                                     |
' |  VBA-code to send personalized emails                                           |
' |  Also on http://www.wimgielis.be                                                |
' |_________________________________________________________________________________|

Sub MainProcedure()

    Dim sEmailApplicLocation As String
    Dim sEmailSender As String
    Dim sEmailReceiver As String
    Dim sEmailSMTPserver As String
    Dim sEmailAttachment As String
    Dim sEmailSubject As String
    Dim sEmailLogfile As String
    Dim sEmailBody As String
    Dim wsInputDataUser As Worksheet
    
    Set wsInputDataUser = ActiveSheet


    ' B1. checks for application location (name and location of the Sendmail exe file (without .exe))
    ' -----------------------------------------------------------------------------------------------
    If blnRangeNameExists("applicationlocation") = False Then
        MsgBox "The named range applicationlocation was not found on the active sheet of this file." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If

    sEmailApplicLocation = wsInputDataUser.Range("applicationlocation").Text
    If UCase$(Right$(sEmailApplicLocation, 4)) = ".EXE" Then
        sEmailApplicLocation = Left(sEmailApplicLocation, Len(sEmailApplicLocation) - 4)
    End If

    If blnIsFilledIn(sEmailApplicLocation) = False Then
        MsgBox "The name and the location of the Sendmail executable was not filled in." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If

    If blnFileFolderExists(sEmailApplicLocation & ".exe") = False Then
        MsgBox "The file (" & sEmailApplicLocation & ".exe" & ") does not exist." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If


    ' B2. checks for the email address of the sender
    ' ----------------------------------------------
    If blnRangeNameExists("emailsender") = False Then
        MsgBox "The named range emailsender was not found on the active sheet of this file." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If

    sEmailSender = wsInputDataUser.Range("emailsender").Text

    If sEmailSender <> vbNullString And blnIsValidEmail(sEmailSender) = False Then
        MsgBox "The email address for the sender seems to be incorrect." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If


    ' B3. checks for the email address of the receiver
    ' ------------------------------------------------
    If blnRangeNameExists("emailreceiver") = False Then
        MsgBox "The named range emailreceiver was not found on the active sheet of this file." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If

    sEmailReceiver = wsInputDataUser.Range("emailreceiver").Text

    If blnIsFilledIn(sEmailReceiver) = False Then
        MsgBox "The email address of the receiver was not filled in." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    Else
        If blnIsValidEmail(sEmailReceiver) = False Then
            MsgBox "The email address for the receiver seems to be incorrect." & sMSG_STOP_EXECUTION, _
                   sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
            Exit Sub
        End If
    End If


    ' B4. checks for SMTP server
    ' --------------------------
    If blnRangeNameExists("smtpserver") = False Then
        MsgBox "The named range smtpserver was not found on the active sheet of this file." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If

    sEmailSMTPserver = wsInputDataUser.Range("smtpserver").Text
    If blnIsFilledIn(sEmailSMTPserver) = False Then
        MsgBox "The SMTP server name was not filled in." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If


    ' B5. checks for the attachment
    ' -----------------------------
    If blnRangeNameExists("attachment") = False Then
        MsgBox "The named range attachment was not found on the active sheet of this file." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If

    sEmailAttachment = wsInputDataUser.Range("attachment").Text
    If sEmailAttachment <> vbNullString And blnFileFolderExists(sEmailAttachment) = False Then
        MsgBox "The attachment (" & sEmailAttachment & ") does not exist.", sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
    End If


    ' B6. checks for the logfile (name and location)
    ' ----------------------------------------------
    If blnRangeNameExists("logfile") = False Then
        MsgBox "The named range logfile was not found on the active sheet of this file." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If

    sEmailLogfile = wsInputDataUser.Range("logfile").Text
    If sEmailLogfile <> vbNullString And _
       blnFileFolderExists(Left$(sEmailLogfile, InStrRev(sEmailLogfile, Application.PathSeparator))) = False Then
        MsgBox "The log file (" & sEmailLogfile & ") can not be created in the folder " & vbNewLine & _
               "(" & Left$(sEmailLogfile, InStrRev(sEmailLogfile, Application.PathSeparator)) & ")." & sMSG_STOP_EXECUTION, _
               sMSG_ERROR_BUTTON, sMSG_ERROR_ALERT
        Exit Sub
    End If


    ' the application location of the Sendmail.exe file
    sEmailApplicLocation = fSurroundText(sEmailApplicLocation, sDOUBLE_QUOTE)

    ' the sender of the email
    sEmailSender = fSurroundText(sEmailSender, sDOUBLE_QUOTE)

    ' the receiver of the email
    sEmailReceiver = fSurroundText(sEmailReceiver, sDOUBLE_QUOTE)

    ' the attachment of the mail message
    sEmailAttachment = fSurroundText(sEmailAttachment, sDOUBLE_QUOTE)

    ' the subject of the mail message
    sEmailSubject = "This is the report you asked"
    sEmailSubject = fSurroundText(sEmailSubject, sDOUBLE_QUOTE)

    ' the logfile for the status of sent emails
    sEmailLogfile = fSurroundText(sEmailLogfile, sDOUBLE_QUOTE)

    ' the body of the mail message
    sEmailBody = vbNewLine & "Dear colleague," & _
                 vbNewLine & vbNewLine & _
                 "Please find enclosed the report you asked." & _
                 vbNewLine & vbNewLine & _
                 "Best regards," & _
                 vbNewLine & vbNewLine & _
                 "YOUR NAME"

    sEmailBody = fSurroundText(sEmailBody, sDOUBLE_QUOTE)

    Call MailReport(sEmailApplicLocation, _
                    sEmailSender, _
                    sEmailReceiver, _
                    sEmailSMTPserver, _
                    sEmailAttachment, _
                    sEmailSubject, _
                    sEmailLogfile, _
                    sEmailBody)

    MsgBox "Klaar", vbInformation, "Status"

End Sub

Sub MailReport(ByVal sApp As String, _
               ByVal sFrom As String, _
               ByVal sTo As String, _
               ByVal sSMTP As String, _
               ByVal sAttach As String, _
               ByVal sSubject As String, _
               ByVal sLogFile As String, _
               ByVal sMessage As String)

    Dim sCommand As String

    sCommand = sApp & _
             " -q " & _
             " -f " & sFrom & _
             " -t " & sTo & _
             " -s " & sSMTP & _
             " -a " & sAttach & _
             " -u " & sSubject & _
             " -l " & sLogFile & _
             " -m " & sMessage
             
    Shell sCommand, vbHide

End Sub

Function blnIsValidEmail(sEmailAddress As String) As Boolean

    blnIsValidEmail = (sEmailAddress Like "?*@?*.?*")

End Function

Function blnRangeNameExists(sRangeName As String) As Boolean

    On Error Resume Next
    blnRangeNameExists = (Len(ThisWorkbook.Names(sRangeName).Name) <> 0)
    On Error GoTo 0

End Function

Function blnIsFilledIn(sWhat As String) As Boolean

    blnIsFilledIn = (Len(sWhat) > 0)

End Function

Function blnFileFolderExists(sFullPath As String) As Boolean

    On Error GoTo here
    blnFileFolderExists = (Dir(sFullPath, vbDirectory) <> vbNullString)

here:
    On Error GoTo 0

End Function

Function fSurroundText(sText As String, _
                       sSurroundCharacter As String) As String

    fSurroundText = sSurroundCharacter & sText & sSurroundCharacter

End Function

Hoop dat iemand mij opweg kan helpen!

Alvast bedankt
 

Bijlagen

  • Terugbel formulier.xls
    37 KB · Weergaven: 41
  • emailenvanuitexcel.xls
    62 KB · Weergaven: 54
Mijn code bouwt een string op voor de body van de email:

Code: 
' the body of the mail message
    sEmailBody = vbNewLine & "Dear colleague," & _
                 vbNewLine & vbNewLine & _
                 "Please find enclosed the report you asked." & _
                 vbNewLine & vbNewLine & _
                 "Best regards," & _
                 vbNewLine & vbNewLine & _
                 "YOUR NAME"

Dit kan je gerust aanpassen om cellen uit te lezen, en dat aldus weer te geven in de body van de email.

Wigi
 
Hallo Wigi,

Zoals je in het terugbel formulier ziet wordt er telkens in dezelfde cellen informatie geplaatst. Als je dit nu verstuurd zal hij alle info tussen die range copieren en plakken in een nieuw email bericht.

Maar uw bestandje zorgt ervoor dat je geen popup scherm krijgt. Maar deze gegevens mee stuurt in een bijlage. Dit zou ik graag willen voorkomen.

Wat moet ik in de code wijzigen zodat je een range copieerd en plakt in een nieuw email bericht en daarna direct verstuurd aan degene die hebt aangegeven.


De code voor de body lijkt zo erg goed maar hoe werkt het zodat hij deze info mee stuurt wat ik of iemand anders ingeeft.


Zie graag reactie tegemoet.
Alvast bedankt!!
 
Begrijp je wat er in de code in post # 2 gebeurt? En daarvan vertrekkende, kan je dan niet gewoon een soortgelijke tekst opstellen die uitleest wat er in de sheet ingevuld is?

Bvb

Als je wil uitlezen hetgeen in cel A1 staat:

Code: 
' the body of the mail message
    sEmailBody = Range("A1").Text
 
Hallo Wigi,

Ik ben nog even aan het prutsen geweest met uw code.
Niet alles is me duidelijk, misschien zal dat verloop van de tijd wel komen :)

Kijk het bijgevoegd bestandje van u, hier heb ik een aantal dingen uitgehaald wat voor mij niet ter sprake komt. Dat is de bijlage en een logfile.

Maar nu heb ik bij de body aangepast dat er een range van sheet1 als body wordt gebruikt maar dit gaat niet zoals gewenst. Zie volgende code:
Code: 
    ' the body of the mail message
    sEmailBody = Sheets("Sheet1").Range("A1:B4")

Graag weer een sprongetje verder helpen.. :)
Alvast bedankt!
 

Bijlagen

  • emailenvanuitexcel.xls
    48 KB · Weergaven: 51
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan