VB Script to send e-mail

I need a VB Script that will send e-mail, that is not dependent on CDO.  The script will run from desktops that have Outlook...I just do not want to depend on CDO.

Here is the current script:

I just want similar functionality without CDO.
strEmailDomainPos = instr(mailAdr, "@")
		GetEmailDomain = mid(mailAdr , strEmailDomainPos)
	End Function
 
 
	Sub GetSMTPServer 
		set cn = createobject("ADODB.Connection")
		set cmd = createobject("ADODB.Command")
		set rs = createobject("ADODB.Recordset")
 
		set objRoot = getobject("LDAP://RootDSE")
		configurationNC = objRoot.Get("configurationnamingcontext")
 
		cn.open "Provider=ADsDSOObject;"
		cmd.activeconnection = cn
 
		cmd.commandtext = "<LDAP://" & configurationNC & _
              ">;(objectCategory=msExchExchangeServer);name;subtree"
		set rs = cmd.execute
 
		while rs.eof<>true and rs.bof<>true
		      	strSMTPServer = rs(0)
			'msgbox rs(0)
		     	rs.movenext
		wend
	
		cn.close
	End sub
 
	Function GetEmail(strAccountName, strDomainName)
 
		Dim adoLDAPCon, adoLDAPRS, strLDAP
 
		Set adoLDAPCon = CreateObject("ADODB.Connection")
		adoLDAPCon.Provider = "ADsDSOObject"
		adoLDAPCon.Open "ADSI"
		strLDAP = "'LDAP://" & strDomainName & "'"
		Set adoLDAPRS = adoLDAPCon.Execute("select mail from " _
		 & strLDAP & " WHERE objectClass = 'user'"& _
		 " And samAccountName = '" & strAccountName & "'")
		With adoLDAPRS
			If Not .EOF Then
				GetEmail = .Fields("mail")
			Else
			        GetEmail = ""
			End If
		End With
		adoLDAPRS.Close
		Set adoLDAPRS = Nothing
		Set adoLDAPCon = Nothing
	End Function
 
	
	sub sendEmail
 
		Set objEmail = CreateObject("CDO.Message")
		objEmail.From = mailAdr
		objEmail.To = strEmailTo & strEmailDomain 
		msgbox objEmail.To
		objEmail.Subject = Summary.Value
		GetUserAddedInfo()
		objEmail.Textbody = Details.Value & vbCr & vbLf & strbaseInfo & vbCr & vbLf & GetUserAddedInfo 
		objEmail.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
		objEmail.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = _
		     strSMTPServer
		objEmail.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
		objEmail.Configuration.Fields.Update
		objEmail.Send
                ExitProgram
	End Sub

Open in new window

bbanis2kAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
Chris BottomleyConnect With a Mentor Commented:
Apologies just realised you asked for script.

See as modified

Chris
attach = ""
outlookMail "Subject String", _
        "Body data is :", _
        "fred@fred.com", _
        "", _
        "", _
        False, _
        attach <> "", _
        attach
        
Sub outlookMail(strSubject, strBody, strTo, _
                            strCC, strBCC, SendYN, _
                            AttachYN, Attach1)
    Set olApp = CreateObject("Outlook.Application")
    Set olMsg = olApp.CreateItem(0)
    With olMsg
        .To = strTo
        .CC = strCC
        .BCC = strBCC
        .subject = strSubject
        .body = strBody
        If AttachYN And Attach1 <> "" Then
            Attach1 = Replace(Attach1, ",", ";")
            str = Split(Attach1, ";")
            For Each att In str
                .Attachments.Add att
            Next
        End If
        If SendYN Then
            .Send
        Else
            .Display
        End If
    End With 
Set olMsg = Nothing
Set olApp = Nothing
End Sub

Open in new window

0
 
Chris BottomleyCommented:
Hello bbanis2k,

        outlookMail strSubject:="Subject String", _
        strBody:="Body data is :", _
        strTo:="fred@fred.com", _
        SendYN:=False, _
        AttachYN:=attach <> "", _
        Attach1:=attach

Note:
    sendYN if true will send otherwise it will display the email
    attach is a comma seperated string of the filepaths for any attachmnets.

Any Help?

Regards,
Chris
Function outlookMail(strSubject As String, strBody As String, Optional strTo As String, _
                            Optional strCC As String, Optional strBCC As String, Optional SendYN As Boolean, _
                            Optional AttachYN As Boolean = False, Optional Attach1 As String) As Boolean
Dim olApp As Object
Dim olMsg As Object
Dim str() As String
Dim att As Variant 
    Set olApp = CreateObject("Outlook.Application")
    Set olMsg = olApp.CreateItem(0)
    With olMsg
        .To = strTo
        .CC = strCC
        .BCC = strBCC
        .subject = strSubject
        .body = strBody
        If AttachYN And Attach1 <> "" Then
            Attach1 = Replace(Attach1, ",", ";")
            str = Split(Attach1, ";")
            For Each att In str
                .Attachments.Add att
            Next
        End If
        If SendYN Then
            .Send
        Else
            .Display
        End If
    End With 
Set olMsg = Nothing
Set olApp = Nothing
End Function

Open in new window

0
 
Chris BottomleyCommented:
bbanis2k

What is the status of this Q from your perspective?

Chris
0
 
bbanis2kAuthor Commented:
Thank you!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.