Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Automated emailing script no longer works

Status
Not open for further replies.

medic

Programmer
Jun 14, 2000
459
US
I got an automated emailing job setup in the SQL Server Agent that used to work in our previous SQL server at office. Now, it doesn't work on our new server. I've been thinking it's the new firewall settings preventing it to run successfuly. Can you guys tell me what components need to be setup or installed in the SQL server to make this work again? Here's the ActiveX script I setup in the SQL Server Agent job:
Code:
Dim lObjConn
Dim lObjRs
Dim lStrSQL
Dim lObjMailer
Dim dewdate
Dim filesys, getname, fpath
Dim mapsw, getdir, newdrive
Dim WshNetwork
Dim usrname,passwd
Set lObjConn = CreateObject("ADODB.Connection")
lObjConn.Mode = 3
lObjConn.Open _
  "Provider=SQLOLEDB.1;Data Source=myservername;" & _
	"Initial Catalog=mydatabase;User ID=myuserid;Password=mypassword;"
Set lObjRs = CreateObject("ADODB.Recordset")
lObjRs.cursortype = 1
lObjRs.cursorlocation = 2
lObjRs.locktype = 3
lStrSQL = "SELECT [From], [To], [Subject], [Body], [Importance], " & _
  "[BodyFormat], [MailFormat], [DueDate], [Attachment], [Recurrence] " & _
  "FROM [Email]"
lObjRs.Open lStrSQL, lObjConn
While Not lObjRs.EOF
  If IsNull(lObjRs(7)) then
    dewdate = Now()
  else
    dewdate = lObjRs(7)
  end if
  if dewdate<=Now() then
    Set lObjMailer = CreateObject("CDONTS.NewMail")
    lObjMailer.From	= lObjRs(0) & ""
    lObjMailer.To	= lObjRs(1) & ""
    lObjMailer.Subject = lObjRs(2) & ""
    lObjMailer.Body = lObjRs(3) &  ""
    mapsw = false
    If not IsNull(lObjRs(8)) and Trim(lObjRs(8))<>"" then
      Set filesys = CreateObject ("Scripting.FileSystemObject")
      fpath = filesys.GetAbsolutePathName(Trim(lObjRs(8)))
      If left(Trim(lObjRs(8)),2)="\\" then
        Set WshNetwork = CreateObject("wscript.network")
        newdrive = "y:"
        On Error Resume Next
        WshNetwork.removenetworkdrive newdrive
        If Err <> 0 Then
          Err.Clear
        End if
        On Error GoTo 0
        getname = filesys.GetFileName(fpath)
        getdir = left(fpath,instr(fpath,getname)-2)
        mapsw = true
        usrname = "mylocaldomain\administrator"
        passwd = "myadminpassword"
        WshNetwork.mapnetworkdrive newdrive, getdir, , usrname, passwd
        fpath = getdir & "\" & getname
      end if
      If filesys.FileExists(fpath) Then
        lObjMailer.AttachFile(fpath)
      End If
    end if
    If IsNull(lObjRs(4)) then
      lObjMailer.Importance	= 1
    else
      lObjMailer.Importance	= lObjRs(4)
    end if
    If IsNull(lObjRs(5)) then
      lObjMailer.BodyFormat	= 1
    else
      lObjMailer.BodyFormat	=  lObjRs(5)
    end if
    If IsNull(lObjRs(6)) then
      lObjMailer.MailFormat	= 1
    else
      lObjMailer.MailFormat	= lObjRs(6)
    end if
    lObjMailer.Send
    If not IsNull(lObjRs(8)) and Trim(lObjRs(8))<>"" then
      Set filesys = nothing
      if mapsw then
        On Error Resume Next
        WshNetwork.removenetworkdrive newdrive
        If Err <> 0 Then
          Err.Clear
        End if
        On Error GoTo 0
        Set WshNetwork = Nothing
      end if
    end if
    If not IsNull(lObjRs(9)) and lObjRs(9)>0 then
      lObjRs(7)  = dewdate +  lObjRs(9)
      lObjRs.Update
    else
      lObjRs.Delete
    end if
    Set lObjMailer = Nothing
  end if
  lObjRs.MoveNext
Wend
lObjRs.Close
lObjConn.Close
Set lObjRs = Nothing
Set lObjConn = Nothing
Does it need SQL Mail setup or Outlook installed in the server? I don't see any relation as I use CDONTS object in it.
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top