Send Smtp Email

FUNCTION SendSmtpEmail

* strServ: The SMTP server to use.  Can be in the following formats:
*           xxx.xxx.xxx.xxx  "xxx.xxx.xxx.xxx:port"  "xxx.xxx.xxx.xxx port"
*           ServerName       "servername:port"       "servername port"
* strFrom: The email address to provide as the "FROM" address
* strTo:   The email address to send the email to.
* strSubj: Subject for the email
* strMsg:  The Message to include as the body of the email.
* oFB_Attachments: Comma separated list of files to attach (full path to each file)
*          (for backward compatibility, the Feedback object can be passed as this parameter)
*          All Attachments+message can be at most 16MB right now, because of VFP string size limit.
* oFeedBack: An object with a method "FeedBack" that expects one string property.
*            If not provided, the feedback messages will be output to the console through "?".
*            Pass .NULL. (or an object without "Feedback" method) to turn off all feedback.
*
* Updated: April 1, 2004: Fixed RCPT TO handling to properly
*                         bracket the email address.

LPARAMETERS strServ, strFrom, strTo, strSubj, strMsg, oFB_cAttachments, oFeedBack
#DEFINE crlf chr(13)+chr(10)
#DEFINE TIME_OUT 5

LOCAL Sock, llRet, lnI, laTO[1], lnCnt, lcServ, lnServPort
LOCAL lnTime, lcOutStr, Junk, lcAttachments, loFB, laAtch[1], lnAtchCnt
LOCAL laFiles[1]

lcMsg         = strMsg
lcAttachments = oFB_cAttachments
loFB          = oFeedback
if TYPE('oFB_cAttachments')='O'
  loFB = oFB_cAttachments
  lcAttachments = ''
endif

* Load Attachments
if TYPE('lcAttachments')='C' and not empty(lcAttachments)
  lnAtchCnt = ALINES( laAtch, StrTran(lcAttachments,',',chr(13)) )
  lcMsg = lcMsg + crlf + crlf
  for lnI = 1 to lnAtchCnt
    if ADIR(laFiles,laAtch[lnI])=0
      GiveFeedBack( loFB, "ERROR: Attachment Not Found:"+laAtch[lnI] )
      RETURN .F.
    endif
    lcAtch = FileToStr( laAtch[lnI] )
    if empty(lcAtch)
      GiveFeedBack( loFB, "ERROR: Attachment Empty/Could not be Read:"+laAtch[lnI] )
      RETURN .F.
    endif

    GiveFeedBack( loFB, "Encoding file: "+laAtch[lnI] )
    lcAtch = UUEncode( laAtch[lnI], lcAtch )

    lcMsg = lcMsg + lcAtch
    lcAtch = '' && free memory
  endfor
endif


GiveFeedBack( loFB, "Connecting to Server: "+strServ )

Sock=create('mswinsock.winsock')
** OR
*  Sock=create('vfpWinSock')
** to use the winsock emulator class below (wayyyy below!) to avoid
**   the licensing issues stemming from OCX's, and to avoid having to
**   register MSWINSCK.OCX on the customers' machines.

llRet = .F.



lnServPort = 25
lcServ     = strServ
do case && Find Port
  case ':' $ lcServ
    lnAt = at(':',lcServ)
    lnServPort = val( Substr(lcServ, lnAt+1) )
    lcServ = left( lcServ, lnAt-1 ) && moved below "lnServPort =...."
    if lnServPort<=0
      lnServPort = 25
    endif
  case ' ' $ lcServ
    lnAt = at(' ',lcServ)
    lnServPort = val( Substr(lcServ, lnAt+1) )
    lcServ = left( lcServ, lnAt-1 ) && moved below "lnServPort =...."
    if lnServPort<=0
      lnServPort = 25
    endif
endcase

sock.Connect(strServ,lnServPort)
lnTime = seconds()

DO WHILE .T. && Control Loop

  if sock.State <> 7 && Connected
    GiveFeedBack( loFB, "Waiting to connect..." )
    inkey(0.1)
    if seconds() - lnTime > TIME_OUT
      GiveFeedBack( loFB, "Connect Timed Out")
      EXIT && Leave Control Loop
    endif
    LOOP  && Wait to connect
  endif

  GiveFeedBack( loFB, "Connected." )

  if not ReadWrite(sock,"HELO " + alltrim(strServ), 220)
    GiveFeedBack( loFB, "Failed HELO" )
    EXIT && Leave Control Loop
  endif

  If Not ReadWrite(sock,"MAIL FROM: " + alltrim(strFrom), 250)
    GiveFeedBack( loFB, "Failed MAIL" )
    EXIT
  endif

  lnCnt = aLines(laTo, ChrTran(strTo,' ,;',chr(13)))
  * once for each email address
  for lnI = 1 to lnCnt
    if not empty(laTo[lnI])
      lcTo = iif( '<' $ laTo[lnI], laTo[lnI], '<' + alltrim(laTo[lnI]) + '>' )
      If Not ReadWrite(sock,"RCPT TO: " + lcTo, 250)
        GiveFeedBack( loFB, "RCPT Failed" )
        EXIT && Leave Control Loop
      endif
    endif
  endfor

  If Not ReadWrite(sock,"DATA", 250)
    GiveFeedBack( loFB, "Failed DATA" )
    EXIT && Leave Control Loop
  endif
  * tran(day(date()))+' '+tran(month(date()))+' '+tran(year(date()));
  *    + ' ' +tran(hour(datetime()))+':'+tran(minute(datetime()))+':'+tran(sec(datetime())) +crlf

  lcOutStr = "DATE: " + GetSMTPDateTime() +crlf;
           + "FROM: " + alltrim(strFrom) + CrLf ;
           + "TO: " + alltrim(strTo) + CrLf ;
           + "SUBJECT: " + alltrim(strSubj) ;
           + crlf ;
           + crlf ;
           + lcMsg
  * remove any inadvertant end-of-data marks:
  lcOutStr = StrTran(lcOutStr, crlf+'.'+crlf, crlf+'. '+crlf)
  * Place end of data mark on end:
  lcOutStr = lcOutStr + crlf + "."
  If Not ReadWrite(sock,lcOutStr, 354 )

    GiveFeedBack( loFB, "Failed DATA (Cont'd)" )
    EXIT && Leave Control Loop
  ENDIF

  * Simon Cropper: If using vfpWinSock and you are sending emails with large attachements you should
  * delay the following QUIT command until the email has has a chance to 'get out the building', otherwise
  * the program enters the IF...ENDIF construct and exits the DO...ENDDO without the llRet being set to TRUE.
  * Outcome: Email sent but program records an error => user keeps trying to send email = upset customer!

  If Not ReadWrite(sock,"QUIT", 250)
    GiveFeedBack( loFB, "Failed QUIT" )
    EXIT && Leave Control Loop
  endif

  GiveFeedBack( loFB, "Email Sent!" )
  llRet = .T.
  EXIT && Leave Control Loop
ENDDO

* Do cleanup code.
Junk = repl(chr(0),1000)
if sock.state = 7 && Connected
  sock.GetData(@Junk)
endif
sock.close
sock = .null.
RETURN llRet
*--------------------------------------------------
Function GiveFeedback( oFB, cMsg )
  if VarType(oFB)='O' or IsNull(oFB)
    if NOT IsNull(oFB) and PEMStatus(oFB,'Feedback',3)='Method'
      RETURN oFB.Feedback( cMsg )
    else
      RETURN .T. && Hide Feedback
    endif
  else
    ?cMsg
  endif
ENDFUNC
*--------------------------------------------------
  FUNCTION GetSMTPDateTime
  * Wed, 12 Mar 2003 07:54:56 -0500
  LOCAL lcRet, ltDT, lnBias
    ltDT = DateTime()
    if 'UTIL' $ set('PROC')
      lnBias = GetTimeZone('BIAS') && In Util.prg
    else
      lnBias = -5 && EST
    endif
    lcBias = iif( lnBias<0, '+', '-' )
    lnBias = abs(lnBias)
    lcBias = lcBias+PadL(Tran(lnBias/60),2,'0')+PadL(Tran(lnBias%60),2,'0')
    lcRet = LEFT( CDOW(ltDT), 3 )+', '+Str( Day(ltDt), 2 ) + ' ' + LEFT( CMONTH(ltDT), 3);
            +' '+TRAN( Year(ltDT) )+' '+PadL(Tran(hour(ltDT)),2,'0')+':';
            +PadL(Tran(Minute(ltDT)),2,'0')+':';
            +PadL(Tran(Sec(ltDT)),2,'0')+' ';
            +lcBias
  RETURN lcRet
  ENDFUNC
*--------------------------------------------------
Function ReadWrite( oSock, cMsgOut, iExpectedCode )
LOCAL cMsgIn, iCode, lnTime
  lnTime = seconds()

  do while oSock.BytesReceived = 0
*   ?"Waiting to Receive data..."
   inkey(0.2)
   if seconds() - lnTime > TIME_OUT
*     ?"Timed Out"
     return .F.
   endif
  enddo

  cMsgIn = repl(chr(0),1000)
  oSock.GetData(@cMsgIn)
*?"expected:",iExpectedCode
*
*?"resp:",cMsgIn
  iCode = Val(Left(cMsgIn, 3))
*?"Got:",icode
  If iCode = iExpectedCode
    oSock.SendData( cMsgOut + CrLf )
  Else
*    ?"Failed; Code="+cMsgin
*    ?"Code="+tran(iCode)
    RETURN .F.
  Endif
RETURN .T.
FUNCTION GetTimeZone( pcFunc )
* Purpose: Return the Time Zone bias or description
*   Input: pcFunc = "BIAS" or Missing... return the bias in Minutes
*                     ( GMT = LocalTime + Bias )
*          pcFunc = "NAME" ... Return the time zone name.
*  Author: William GC Steinford
***********************************************************

*!*	typedef struct _TIME_ZONE_INFORMATION {
*!*	    LONG       Bias;                    2:  1-  2
*!*	    WCHAR      StandardName[ 32 ];     64:  3- 66
*!*	    SYSTEMTIME StandardDate;           16: 67- 82
*!*	    LONG       StandardBias;            2: 83- 84
*!*	    WCHAR      DaylightName[ 32 ];     64: 85-148
*!*	    SYSTEMTIME DaylightDate;           16:149-164
*!*	    LONG       DaylightBias;            2:165-166
*!*	} TIME_ZONE_INFORMATION, *PTIME_ZONE_INFORMATION;
*!*	typedef struct _SYSTEMTIME {
*!*	    WORD wYear;
*!*	    WORD wMonth;
*!*	    WORD wDayOfWeek;
*!*	    WORD wDay;
*!*	    WORD wHour;
*!*	    WORD wMinute;
*!*	    WORD wSecond;
*!*	    WORD wMilliseconds;
*!*	} SYSTEMTIME, *PSYSTEMTIME;
LOCAL lcTZInfo, lcDesc
lcTZInfo = num2dword(0);
           +repl(chr(0),64)+repl(num2Word(0),8)+num2dword(0);
           +repl(chr(0),64)+repl(num2Word(0),8)+num2dword(0)
DECLARE INTEGER GetTimeZoneInformation IN kernel32.dll;
    STRING @ lpTimeZoneInformation
#DEFINE TIME_ZONE_ID_INVALID  0xFFFFFFFF
#DEFINE TIME_ZONE_ID_UNKNOWN  0
#DEFINE TIME_ZONE_ID_STANDARD 1
#DEFINE TIME_ZONE_ID_DAYLIGHT 2
lcRes = GetTimeZoneInformation( @lcTZInfo )
lnBias = Buf2DWord( lcTZInfo )
lcDesc = "Unknown"
do case
  case lcRes=TIME_ZONE_ID_STANDARD
    lcDesc = substr( lcTZInfo, 3, 64 )
    lcDesc = StrConv( lcDesc, 6 ) && 6=Unicode(wide)->DoubleByte
    lcDesc = strTran( lcDesc, chr(0), '' )
  case lcRes=TIME_ZONE_ID_DAYLIGHT
    lcDesc = substr( lcTZInfo, 3, 64 )
    lcDesc = StrConv( lcDesc, 6 )
    lcDesc = strTran( lcDesc, chr(0), '' )
endcase
if varType(pcFunc)='C' and pcFunc='NAME'
  RETURN lcDesc
endif

RETURN lnBias
ENDFUNC
* * *
* dword is compatible with LONG
FUNCTION num2Long( lnValue )

  RETURN num2Dword(lnValue)
ENDFUNC
FUNCTION num2dword (lnValue)
#DEFINE m0       256
#DEFINE m1     65536
#DEFINE m2  16777216
  LOCAL b0, b1, b2, b3
  b3 = Int(lnValue/m2)
  b2 = Int((lnValue - b3*m2)/m1)
  b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
  b0 = Mod(lnValue, m0)
  RETURN Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
ENDFUNC
* * *
* word is compatible with Integer
FUNCTION num2word (lnValue)
  RETURN Chr(MOD(m.lnValue,256)) + CHR(INT(m.lnValue/256))
ENDFUNC
* * *
FUNCTION buf2word (lcBuffer)
  RETURN Asc(SUBSTR(lcBuffer, 1,1)) + ;
         Asc(SUBSTR(lcBuffer, 2,1)) * 256
ENDFUNC
* * *
FUNCTION  buf2Long (lcBuffer)
  RETURN buf2Dword(lcBuffer)
ENDFUNC
FUNCTION  buf2dword(lcBuffer)
RETURN Asc(SUBSTR(lcBuffer, 1,1)) + ;
       Asc(SUBSTR(lcBuffer, 2,1)) * 256 +;
       Asc(SUBSTR(lcBuffer, 3,1)) * 65536 +;
       Asc(SUBSTR(lcBuffer, 4,1)) * 16777216
ENDFUNC
**************************************************************************************
Function UUEncode( strFilePath, pcFileData )
* Converted by wgcs From VB code at www .vbip.com/winsock/winsock_uucode_02.asp
* strFilePath: Specify the full path to the file to load and UU-encode.
* pcFileData:  an optional parameter.  Specify this, and strFilePath is not loaded,
*              but just the filename from strFilePath is used for the encoding label.
*
LOCAL strFileName, strFileData, i, j, lEncodedLines, ;
      strTempLine, lFileSize, strResult, strChunk

*Get file name
strFileName = JUSTFNAME(strFilePath)
if type('pcFileData')='C'
  strFileData = pcFileData
else
  strFileData = FILETOSTR(strFilePath)
endif

*Insert first marker: "begin 664 ..."
strResult = "begin 664 " + strFileName + chr(10)

*Get file size
lFileSize = Len(strFileData)
lEncodedLines = int(lFileSize / 45) + 1

For i = 1 To lEncodedLines
    *Process file data by 45-bytes cnunks

    *reset line buffer
    strTempLine = ""

    If i = lEncodedLines Then
        *Last line of encoded data often is not
        *equal to 45
      strChunk = strFileData
      StrFileData = ''
    else
      strChunk    = LEFT(   strFileData, 45 )
      StrFileData = SubStr( strFileData, 46 )
    endif

* Thanks to "AllTheTimeInTheWorld" on Tek-Tips.com, it was recognized that
*  the length calculation should be after the correction of the last line
*  with the blankspace symbols:
*    *Add first symbol to encoded string that informs
*    *about quantity of symbols in encoded string.
*    *More often "M" symbol is used.
*   strTempLine = Chr(Len(strChunk) + 32)

    If i = lEncodedLines And (Len(strChunk) % 3<>0) Then
      *If the last line is processed and length of
      *source data is not a number divisible by 3,
      *add one or two blankspace symbols
      strChunk = strChunk + Space( 3 -(Len(strChunk) % 3) )
    endif

    *Now that we know the final length of the last string,
    *Add first symbol to encoded string that informs
    *about quantity of symbols in encoded string.
    *More often "M" symbol is used.
    strTempLine = Chr(Len(strChunk) + 32)


*!*	    For j = 1 To Len(strChunk) Step 3
*!*	        *Break each 3 (8-bits) bytes to 4 (6-bits) bytes
*!*	        *
*!*	        *1 byte
*!*	        strTempLine = strTempLine +  ;
*!*	            Chr(Asc(SubStr(strChunk, j, 1)) / 4 + 32)
*!*	        *2 byte
*!*	        strTempLine = strTempLine +  ;
*!*	            Chr((Asc(SubStr(strChunk, j, 1)) % 4) * 16  ;
*!*	            + Asc(SubStr(strChunk, j + 1, 1)) / 16 + 32)
*!*	        *3 byte
*!*	        strTempLine = strTempLine +  ;
*!*	            Chr((Asc(SubStr(strChunk, j + 1, 1)) % 16) * 4  ;
*!*	            + Asc(SubStr(strChunk, j + 2, 1)) / 64 + 32)
*!*	        *4 byte
*!*	        strTempLine = strTempLine +  ;
*!*	            Chr(Asc(SubStr(strChunk, j + 2, 1)) % 64 + 32)

*!*	    EndFor

    * Faster method:
    For j = 1 To Len(strChunk) Step 3
        *Break each 3 (8-bits) bytes to 4 (6-bits) bytes
        ln1 = Asc(SubStr(strChunk, j, 1))
        ln2 = Asc(SubStr(strChunk, j + 1, 1))
        ln3 = Asc(SubStr(strChunk, j + 2, 1))
        *1 byte
        strTempLine = strTempLine +  Chr(ln1 / 4 + 32) ;
                                  +  Chr((ln1 % 4) * 16  + ln2 / 16 + 32) ;
                                  +  Chr((ln2 % 16) * 4  + ln3 / 64 + 32) ;
                                  +  Chr(ln3 % 64 + 32)
    EndFor


    *add encoded line to result buffer
    strResult = strResult + strTempLine + chr(10)
EndFor
*add the end marker
strResult = strResult + "*" + chr(10) + "end" + chr(10)
*asign return value
return strResult

Function UUDecode(strUUCodeData)
* Converted by wgcs From VB code at www .vbip.com/winsock/winsock_uucode_04.asp
LOCAL lnLines, laLines[1], lcOut, lnI, lnJ
LOCAL strDataLine, intSymbols, strTemp

*Remove first marker

If Left(strUUCodeData, 6) = "begin "
   strUUCodeData = SUBSTR(strUUCodeData, AT(chr(10),strUUCodeData) + 1)
EndIf

*Remove marker of the attachment's end
If Right(strUUCodeData, 5) = "end" + chr(13)+chr(10)
   * Remove last 10 characters:  CR,LF,*,CR,LF,E,N,D,CR,LF
   strUUCodeData = Left(strUUCodeData, Len(strUUCodeData) - 10)
endif
strTemp = ""

*Break decoded data to the strings

*From now each member of the array vDataLines contains
*one line of the encoded data
lnLines = alines(laLines, strUUCodeData)

For lnI = 1 to lnLines
   *Decode data line by line
   strDataLine = laLines[lnI]

   *Extract the number of characters in the string
   *We can figure it out by means of the first string character
   intSymbols = Asc(Left(strDataLine, 1))

   *which we delete because of its uselessness
   strDataLine = SubStr(strDataLine, 2, intSymbols)

   *Decode the string by 4 bytes portion.
   *From each byte remove two oldest bits.
   *From remain 24 bits make 3 bytes
   For lnJ = 1 To Len(strDataLine) Step 4
      *1 byte
      strTemp = strTemp + Chr( (Asc(SubStr(strDataLine, lnJ,   1)) - 32) * 4  ;
                              +(Asc(SubStr(strDataLine, lnJ+1, 1)) - 32) / 16   )
      *2 byte
      strTemp = strTemp + Chr( (Asc(SubStr(strDataLine, lnJ+1, 1)) % 16) * 16 ;
                              +(Asc(SubStr(strDataLine, lnJ+2, 1)) - 32) / 4    )
      *3 byte

      strTemp = strTemp + Chr( (Asc(SubStr(strDataLine, lnJ+2, 1)) % 4) * 64 ;
                              + Asc(SubStr(strDataLine, lnJ+3, 1)) - 32)
   ENDFOR
   *Write decoded string to the file
   lcOut = lcOut + strTemp

   *Clear the buffer in order to receive the next
   *line of the encoded data
   strTemp = ""
ENDFOR

RETURN lcOut
ENDFUNC

DEFINE CLASS vfpWinSock As Session

  * This class was written by William GC Steinford
  *   based on code posted by AnatoliyMogylevets on fox.wikis.com
  * This class is designed to mimic the features of the MSWINSCK.WinSock activeX control
  *   which are used by SendSmtpEmail

  * Public Interface Properties:
  *   N - State
  *   N - BytesReceived (read only)
  *   C - Host          (read only)
  *   C - IP            (read only)
  *   N - Port          (read only)
  *   C - cIn           (read/write)
  *
  * Public Interface Methods:
  *   L - Connect( cServer, nServerPort )
  *   L - Close()
  *   L - SendData( cData )
  *   L - GetData( @cDataOut )

  * State property Values
  *   0 Default. Closed
  *   1 Open
  *   2 Listening
  *   3 Connection pending
  *   4 Resolving host
  *   5 Host resolved
  *   6 Connecting
  *   7 Connected
  *   8 Peer is closing the connection
  *   9 Error
  State         = 0
  BytesReceived = 0

  host     = ""
  IP       = ""
  Port     = 80
  hSocket  = 0
  cIn      = ''

  WaitForRead = 0

  * Performance Adjustable Constants:
  #DEFINE READ_SIZE                16384
  #DEFINE READ_FROM_SERVER_TIMEOUT 200

  * API Constants:
  #DEFINE SMTP_PORT 25
  #DEFINE HTTP_PORT 80
  #DEFINE AF_INET 2
  #DEFINE SOCK_STREAM 1
  #DEFINE IPPROTO_TCP 6
  #DEFINE SOCKET_ERROR -1
  #DEFINE FD_READ 1
  #DEFINE HOSTENT_SIZE 16

  FUNCTION Connect( tcServer, tnServerPort )
    LOCAL cBuffer, cPort, cHost, lResult

    THIS.IP = THIS.GetIP(tcServer)
    IF EMPTY(THIS.IP)
      RETURN .F.
    ENDIF
    THIS.Host = tcServer

    THIS.Port = tnServerPort

    THIS.hSocket = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
    IF THIS.hSocket = SOCKET_ERROR
        RETURN .F.
    ENDIF

    THIS.State = 6
    cPort = THIS.num2word(htons(THIS.Port))
    nHost = inet_addr(THIS.IP)
    cHost = THIS.num2dword(nHost)
    cBuffer = THIS.num2word(AF_INET) + cPort + cHost + Repli(Chr(0),8)
    lResult = (ws_connect(THIS.hSocket, @cBuffer, Len(cBuffer))=0)
    IF lResult
      THIS.State = 7
    ELSE
      THIS.State = 0
    ENDIF
  RETURN lResult

  FUNCTION Close
    if THIS.hSocket<>SOCKET_ERROR
      = closesocket(THIS.hSocket)
    endif
    THIS.hSocket = SOCKET_ERROR
    THIS.State = 0
  ENDFUNC

  FUNCTION SendData( cData )
    LOCAL cBuffer, nResult
    cBuffer = cData
    nResult = send(THIS.hSocket, @cBuffer, Len(cBuffer), 0)
    IF nResult = SOCKET_ERROR
        RETURN .F.
    ENDIF
    RETURN .T.
  ENDFUNC

  FUNCTION GetData( tcOutData )
    * NOTE: tcOutData MUST be passed by reference, ie: Sock.GetData( @Outstr )
    tcOutData = THIS.cIn
    THIS.cIn = ''
  ENDFUNC

  * Private methods follow:

  FUNCTION BytesReceived_Access
    THIS.Rd()
    RETURN LEN(THIS.cIn)
  ENDFUNC

  PROTECTED FUNCTION Rd
    LOCAL hEventRead, nWait, cRead, cRecv, nRecv, nFlags, lcRead
    DO WHILE .T.
        * creating event, linking it to the socket and wait
        hEventRead = WSACreateEvent()
        = WSAEventSelect(THIS.hSocket, hEventRead, FD_READ)

        * 1000 milliseconds can be not enough
        THIS.WaitForRead = WSAWaitForMultipleEvents(1, @hEventRead, 0, READ_FROM_SERVER_TIMEOUT, 0)
        = WSACloseEvent(hEventRead)

        IF THIS.WaitForRead <> 0 && error or timeout
            EXIT
        ENDIF

        * reading data from connected socket
*This didn't belong here:
*        THIS.cIn = THIS.cIn+THIS.Rd()

        cRecv = Repli(Chr(0), READ_SIZE)
        nFlags = 0
        nRecv = recv(THIS.hSocket, @cRecv, READ_SIZE, nFlags)


        IF nRecv>0
          THIS.cIn = THIS.cIn + LEFT(cRecv, nRecv))
        ENDIF
    ENDDO
  ENDFUNC

  PROCEDURE Init()
    DECLARE INTEGER gethostbyname IN ws2_32 STRING host
    DECLARE STRING inet_ntoa IN ws2_32 INTEGER in_addr
    DECLARE INTEGER socket IN ws2_32 INTEGER af, INTEGER tp, INTEGER pt
    DECLARE INTEGER closesocket IN ws2_32 INTEGER s
    DECLARE INTEGER WSACreateEvent IN ws2_32
    DECLARE INTEGER WSACloseEvent IN ws2_32 INTEGER hEvent
    DECLARE GetSystemTime IN kernel32 STRING @lpSystemTime
    DECLARE INTEGER inet_addr IN ws2_32 STRING cp
    DECLARE INTEGER htons IN ws2_32 INTEGER hostshort
    DECLARE INTEGER WSAStartup IN ws2_32 INTEGER wVerRq, STRING lpWSAData
    DECLARE INTEGER WSACleanup IN ws2_32

    DECLARE INTEGER connect IN ws2_32 AS ws_connect ;
        INTEGER s, STRING @sname, INTEGER namelen

    DECLARE INTEGER send IN ws2_32;
        INTEGER s, STRING @buf, INTEGER buflen, INTEGER flags

    DECLARE INTEGER recv IN ws2_32;
        INTEGER s, STRING @buf, INTEGER buflen, INTEGER flags

    DECLARE INTEGER WSAEventSelect IN ws2_32;
        INTEGER s, INTEGER hEventObject, INTEGER lNetworkEvents

    DECLARE INTEGER WSAWaitForMultipleEvents IN ws2_32;
        INTEGER cEvents, INTEGER @lphEvents, INTEGER fWaitAll,;
        INTEGER dwTimeout, INTEGER fAlertable

    DECLARE RtlMoveMemory IN kernel32 As CopyMemory;

        STRING @Dest, INTEGER Src, INTEGER nLength


    IF WSAStartup(0x202, Repli(Chr(0),512)) <> 0
      * unable to initialize Winsock on this computer
      RETURN .F.
    ENDIF
    RETURN .T.
  ENDPROC

  PROCEDURE Destroy

    = WSACleanup()
  ENDPROC

  PROTECTED FUNCTION GetIP( pcHost )
      LOCAL nStruct, nSize, cBuffer, nAddr, cIP
      nStruct = gethostbyname(pcHost)
      IF nStruct = 0
          RETURN ""
      ENDIF
      cBuffer = Repli(Chr(0), HOSTENT_SIZE)
      cIP = Repli(Chr(0), 4)
      = CopyMemory(@cBuffer, nStruct, HOSTENT_SIZE)
      = CopyMemory(@cIP, THIS.buf2dword(SUBS(cBuffer,13,4)),4)
      = CopyMemory(@cIP, THIS.buf2dword(cIP),4)
  RETURN inet_ntoa(THIS.buf2dword(cIP))
  ENDFUNC

  FUNCTION buf2dword(lcBuffer)
    RETURN Asc(SUBSTR(lcBuffer, 1,1)) + ;
        BitLShift(Asc(SUBSTR(lcBuffer, 2,1)), 8) +;
        BitLShift(Asc(SUBSTR(lcBuffer, 3,1)), 16) +;
        BitLShift(Asc(SUBSTR(lcBuffer, 4,1)), 24)
  ENDFUNC

  FUNCTION num2dword(lnValue)
    *#DEFINE m0 256      2^8
    *#DEFINE m1 65536    2^16
    *#DEFINE m2 16777216 2^24
      IF lnValue < 0
          lnValue = 0x100000000 + lnValue
      ENDIF
      LOCAL b0, b1, b2, b3
      b3 = Int(lnValue/2^24)
      b2 = Int((lnValue - b3*2^24)/2^16)
      b1 = Int((lnValue - b3*2^24 - b2*2^16)/2^8)
      b0 = Mod(lnValue, 2^8)
    RETURN Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
  ENDFUNC

  FUNCTION num2word(lnValue)
    RETURN Chr(MOD(m.lnValue,256)) + CHR(INT(m.lnValue/256))
  ENDFUNC
ENDDEFINE

#DEFINE CrLf  Chr(13)+Chr(10)
LOCAL cServer, cSender, cRecipient, obj
cServer = "smtp.smtpserver.com"
cSender = "sender@smalloffice.com"
cRecipient = "postbox@headquarter.com"

obj = CreateObject("Tsmtp", cServer, cSender, cRecipient)
IF VARTYPE(obj) <> "O"
	= MessageB("Unable to initiaze Tsmtp object.   " + Chr(13) +;
		"Check Host, Sender, and Recipient parameters.     ", 48, " Error")
ELSE
	WITH obj
		.subject = "Testing Winsock SMTP functionality"
		.body = "Test message:" + CrLf + CrLf +;
			"Windows Sockets (Winsock) provides a general-purpose networking " +;
			"application programming interface (API) based on the socket interface " +;
			"from the University of California at Berkeley. " + CrLf + CrLf +;
			"Winsock is designed to run efficiently on Windows OSs while maintaining " +;
			"compatibility with the Berkeley Software Distribution (BSD) standard, " +;
			"known as Berkeley Sockets."
		.SendMail()
	ENDWITH
	IF USED("csLog")
		SELECT csLog
		GO TOP
		BROW NORMAL NOWAIT
	ENDIF
ENDIF
* end of main

DEFINE CLASS Tsmtp As Custom
#DEFINE SMTP_PORT     25  && default SMTP port
#DEFINE AF_INET       2
#DEFINE SOCK_STREAM   1
#DEFINE IPPROTO_TCP   6
#DEFINE SOCKET_ERROR  -1
#DEFINE FD_READ       1
	host=""
	IP=""
	sender=""
	recipient=""
	subject=""
	body=""
	hSocket=0

PROCEDURE Init(cServer, cSender, cRecipient)
	DO decl
	IF WSAStartup(0x202, Repli(Chr(0),512)) <> 0
	* unable to initialize Winsock on this computer
		RETURN .F.
	ENDIF

	THIS.host = cServer
	THIS.sender = cSender
	THIS.recipient = cRecipient

	IF Not THIS.InitCheck()
		= WSACleanup()
		RETURN .F.
	ENDIF

FUNCTION InitCheck
	IF EMPTY(THIS.host) Or EMPTY(THIS.recipient);
		Or EMPTY(THIS.sender)
	* invalid Host or sender/recipient email address
		RETURN .F.
	ENDIF
	THIS.IP = THIS.GetIP()
	IF EMPTY(THIS.IP)
	* can not resolve Host name to IP address
		RETURN .F.
	ENDIF
RETURN .T.

PROCEDURE Destroy
	= WSACleanup()

PROTECTED FUNCTION IsMailValid  && just a minimal check
RETURN Not (EMPTY(THIS.sender) Or EMPTY(THIS.recipient);
	Or EMPTY(THIS.subject+THIS.body))

PROTECTED FUNCTION GetIP
#DEFINE HOSTENT_SIZE 16
	LOCAL nStruct, nSize, cBuffer, nAddr, cIP
	nStruct = gethostbyname(THIS.host)
	IF nStruct = 0
		RETURN ""
	ENDIF
	cBuffer = Repli(Chr(0), HOSTENT_SIZE)
	cIP = Repli(Chr(0), 4)
	= CopyMemory(@cBuffer, nStruct, HOSTENT_SIZE)
	= CopyMemory(@cIP, buf2dword(SUBS(cBuffer,13,4)),4)
	= CopyMemory(@cIP, buf2dword(cIP),4)
RETURN inet_ntoa(buf2dword(cIP))

PROTECTED FUNCTION ConnectTo
	LOCAL cBuffer, cPort, cHost, lResult
	cPort = num2word(htons(SMTP_PORT))
	nHost = inet_addr(THIS.IP)
	cHost = num2dword(nHost)
	cBuffer = num2word(AF_INET) + cPort + cHost + Repli(Chr(0),8)
	lResult = (ws_connect(THIS.hSocket, @cBuffer, Len(cBuffer))=0)
RETURN lResult

FUNCTION SendMail
	IF Not THIS.IsMailValid()
		RETURN .F.
	ENDIF
	THIS.hSocket = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
	IF THIS.hSocket = SOCKET_ERROR
		RETURN .F.
	ENDIF

	LOCAL lResult
	IF THIS.ConnectTo()
           **   Most servers expect the server name after HELO:
	   ** THIS.snd("HELO", .T.)
		THIS.snd("HELO "+THIS.host, .T.)
		THIS.snd("MAIL FROM:<" + THIS.sender + ">", .T.)
		THIS.snd("RCPT TO:<" + THIS.recipient + ">", .T.)
		THIS.snd("DATA", .T.)
		THIS.snd("From: " + THIS.sender)
		THIS.snd("To: " + THIS.recipient)
		THIS.snd("Subject: " + THIS.subject)
		THIS.snd("")
		THIS.snd(THIS.body)
		THIS.snd(".", .T.)
		THIS.snd("QUIT", .T.)
		lResult = .T.
	ELSE
		= MessageB("Unable to connect to [" + THIS.host +;
			"] on port " + LTRIM(STR(SMTP_PORT)) + ".   ",;
			48, " Connection error")
		lResult = .F.
	ENDIF
	= closesocket(THIS.hSocket)
RETURN lResult
ENDFUNC

PROTECTED FUNCTION snd(cData, lResponse)
	THIS.writelog(1, cData)
	LOCAL cBuffer, nResult, cResponse
	cBuffer = cData + CrLf
	nResult = send(THIS.hSocket, @cBuffer, Len(cBuffer), 0)

	IF nResult = SOCKET_ERROR
		RETURN .F.
	ENDIF
	IF Not lResponse
		RETURN .T.
	ENDIF

	LOCAL hEventRead, nWait, cRead
	DO WHILE .T.
		* creating event, linking it to the socket and wait
		hEventRead = WSACreateEvent()
		= WSAEventSelect(THIS.hSocket, hEventRead, FD_READ)

		* 1000 milliseconds can be not enough
		nWait = WSAWaitForMultipleEvents(1, @hEventRead,;
			0, 1000, 0)
		= WSACloseEvent(hEventRead)

		IF nWait <> 0  && error or timeout
			EXIT
		ENDIF
		
		* reading data from connected socket


		cRead = THIS.rd()
		IF Not EMPTY(cRead)
			THIS.writelog(0, cRead)
		ENDIF
	ENDDO
RETURN .T.

PROTECTED FUNCTION rd
#DEFINE READ_SIZE 16384
	LOCAL cRecv, nRecv, nFlags
	cRecv = Repli(Chr(0), READ_SIZE)
	nFlags = 0
	nRecv = recv(THIS.hSocket, @cRecv, READ_SIZE, nFlags)
RETURN Iif(nRecv<=0, "", LEFT(cRecv, nRecv))

PROTECTED PROCEDURE writelog(nMode, cMsg)
	IF Not USED("csLog")
		CREATE CURSOR csLog(dir I, msg C(250))
	ENDIF
	? cMsg
	cMsg = CrLf + cMsg + CrLf


	LOCAL nIndex, nPos0, nPos1
	nIndex = 1
	DO WHILE .T.
		nPos0 = AT(CrLf, cMsg, nIndex)
		nPos1 = AT(CrLf, cMsg, nIndex+1)
		IF nPos1 = 0
			EXIT
		ENDIF
		cLog = SUBSTR(cMsg, nPos0, nPos1-nPos0)
		cLog = STRTRAN(STRTRAN(cLog, Chr(13),""),Chr(10),"")
		IF Not EMPTY(cLog)
			INSERT INTO csLog VALUES (m.nMode, m.cLog)
		ENDIF
		nIndex = nIndex + 1
	ENDDO
ENDDEFINE

PROCEDURE decl
	DECLARE INTEGER gethostbyname IN ws2_32 STRING host
	DECLARE STRING inet_ntoa IN ws2_32 INTEGER in_addr
	DECLARE INTEGER socket IN ws2_32 INTEGER af, INTEGER tp, INTEGER pt
	DECLARE INTEGER closesocket IN ws2_32 INTEGER s
	DECLARE INTEGER WSACreateEvent IN ws2_32
	DECLARE INTEGER WSACloseEvent IN ws2_32 INTEGER hEvent
	DECLARE GetSystemTime IN kernel32 STRING @lpSystemTime
	DECLARE INTEGER inet_addr IN ws2_32 STRING cp
	DECLARE INTEGER htons IN ws2_32 INTEGER hostshort
	DECLARE INTEGER WSAStartup IN ws2_32 INTEGER wVerRq, STRING lpWSAData
	DECLARE INTEGER WSACleanup IN ws2_32

	DECLARE INTEGER connect IN ws2_32 AS ws_connect ;
		INTEGER s, STRING @sname, INTEGER namelen

	DECLARE INTEGER send IN ws2_32;
		INTEGER s, STRING @buf, INTEGER buflen, INTEGER flags

	DECLARE INTEGER recv IN ws2_32;
		INTEGER s, STRING @buf, INTEGER buflen, INTEGER flags

	DECLARE INTEGER WSAEventSelect IN ws2_32;
		INTEGER s, INTEGER hEventObject, INTEGER lNetworkEvents

	DECLARE INTEGER WSAWaitForMultipleEvents IN ws2_32;
		INTEGER cEvents, INTEGER @lphEvents, INTEGER fWaitAll,;
		INTEGER dwTimeout, INTEGER fAlertable

	DECLARE RtlMoveMemory IN kernel32 As CopyMemory;
		STRING @Dest, INTEGER Src, INTEGER nLength

FUNCTION buf2dword(lcBuffer)
RETURN Asc(SUBSTR(lcBuffer, 1,1)) + ;
	BitLShift(Asc(SUBSTR(lcBuffer, 2,1)),  8) +;
	BitLShift(Asc(SUBSTR(lcBuffer, 3,1)), 16) +;
	BitLShift(Asc(SUBSTR(lcBuffer, 4,1)), 24)

FUNCTION num2dword(lnValue)
#DEFINE m0  256
#DEFINE m1  65536
#DEFINE m2  16777216
	IF lnValue < 0
		lnValue = 0x100000000 + lnValue
	ENDIF
	LOCAL b0, b1, b2, b3
	b3 = Int(lnValue/m2)
	b2 = Int((lnValue - b3*m2)/m1)
	b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
	b0 = Mod(lnValue, m0)
RETURN Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)

FUNCTION num2word(lnValue)
RETURN Chr(MOD(m.lnValue,256)) + CHR(INT(m.lnValue/256))

* I'm not really familiar with the smtp code above, but I'll try
* to make this work within its framework.

* Note that you'll probably have to open connection to the SMTP server with 'EHLO'
* not 'HELO' to enable the AUTH command (and other advanced -- eSMTP -- commands)
PROCEDURE SendMessage
	&& connect to server.
	&& send 'EHLO' message
	...
	If ReadWrite('AUTH LOGIN',250)
		if !ReadWrite(STRCONV(this.UserName,13),250) and !ReadWrite(STRCONV(this.Password,13),250)
			WAIT WINDOW 'Username and Password are invalid.'
		endif
	else
		wait window 'AUTH LOGIN not supported by smtp server.'
	ENDIF
	...
	&& continue sending message
ENDPROC

    ReadWrite(sock,"EHLO " + alltrim(strServ), 220)
    ReadWrite(sock,"AUTH LOGIN ",250)
    ReadWrite(sock,strconv(suser,13), 334)
    ReadWrite(sock,strconv(spass,13), 334)

Code which uses direct winsock call has the following issues:

1. Slow perfomance caused by

nWait = WSAWait For Multiple Events(1, @hEventRead, 0, 1000, 0)

For unknown reason this line causes ALWAYS 1 second delay. Thus sending
every e-mail takes always 6 seconds, not related to connection speed at all.

2. Violation of SMTP timeouts can cause message loss.
Code waits only 1 seconds for SMTP server response. Server may not respond during 1 second. According to http://www.faqs.org/rfcs/rfc2821.html timeouts must be a lot bigger.
In this case this code terminates TCP connection and message may
be not sent.

3. It is not possible to attach pdf files to mails.
http://foxsocks.sourceforge.net/ Contains some encoding ideas.

Andrus Moor

---

I used the program to send plain text is ok, but how can I send HTML format ? I tried to add the MIME version to the program as follows;

lcOutStr = "DATE: " + GetSMTPDateTime() +crlf;
+ "FROM: " + alltrim(strFrom) + CrLf ;
+ "TO: " + alltrim(strTo) + CrLf ;
+ "SUBJECT: " + alltrim(strSubj) + CrLf;
+ "MIME-Version: 1.0" + CrLf;
+ "Content-Type: multipart/alternative;" + CrLf;
+ ' boundary = "Ipgo_140520060124"' + CrLf;
+ crlf ;
+ crlf ;
+ lcMsg

and I also added the boundary header "--Ipgo_140520060124" and tailer "--Ipgo_140520060124--" to bound my message, but receiver cannot display the message in the mail box. What can I do ?

Edward ( edwkong@gmail.com )

---

Newest Version Feel free to edit this into a topmost example or whatever to keep it all tidy, I've done lots of testing on the code and through telnet sessions with ms-exchange and hmail I've discovered a range of issues with the code, from timing out to early to all the return codes being off by one!. Below is my modified version which includes login, html format emails, and attachments encoded as base64 (this needs a dll I tried base64 encoding in fox but it was very slow, so I made a dll in c) it's used in a production environment and now works very well (at least for me!).

the base 64 encode dll I made for attachments can be downloaded from
http://www.sendspace.com/file/1lq6za
or
http://www.kensands.co.uk/random/Base64_Library.dll (if my home server is turned on)
it just encodes the named input file to the named output file. feel free to use it.

#Define crlf Chr(13)+Chr(10)
#Define TIME_OUT 100
#Define vfpCr   Chr(13)
#Define vfpLf   Chr(10)
#Define vfpCrLf vfpCr + vfpLf

*********************************************************************************
Function SendEmail ( strFrom, emailTo, strSubj, strMsg, strAttachments, replyto )

If Type('strFrom') == 'C' And strFrom == "?"
	Return "asSendEmail ( strFrom, emailTo, strSubj, strMsg, strAttachments, replyto )"
Endif

Local Sock, llRet, lnI, laTO[1], lnCnt, lcServ, lnServPort
Local lnTime, lcOutStr, Junk, lcAttachments, loFB, laAtch[1], lnAtchCnt
Local laFiles[1], username, pword
Local cMsgIn, iCode

Private exactstate && save the set exact state, this routine requires it to be on

exactstate = Set('exact')
Set Exact On

Set Fullpath On

If Type('strFrom') != 'C' Or strFrom == ""
	strFrom = "mail@mydomain.com"
Endif
If Type('emailto') != 'C' Or emailTo == ""
	emailTo = "recipient@mydomain.com"
Endif
If Type('strsubj') != 'C' Or strSubj == ""
	strSubj = "test email"
Endif
If Type('strmsg') != 'C' Or strMsg == ""
	strMsg = "just a test"
Endif
If Type('strAttachments') != 'C'
	strAttachments = ""
Endif
If Type('replyto') != 'C' Or replyto == ""
	replyto = strFrom
Endif

username = ""
pword = ""

strserv = "MAILSERVER" && mail server name

*** in our system two mailservers are used depending on user name ****
*** the standard for login seems to be username and password encoded as base64
*** try http://makcoder.sourceforge.net/demo/base64.php to do this

	IF strfrom = "email1@test.com"
		strserv = "MAILSERVER"
		username = "BASE64name="
		pword = "BASE64password="
	ENDIF

	IF strfrom = "email2@test.com"
		strserv = "MAILSERVER2"
		username = "BASE64name="
		pword = "BASE64password="
	ENDIF
lcmsg = ""
lcmsg = strMsg
lcAttachments = strAttachments

* Load Attachments
If Type('lcAttachments')='C' And Alltrim(lcAttachments)!=""
	lnAtchCnt = Alines( laAtch, Chrtran(lcAttachments,',;',Chr(13)+Chr(13)) )
	lcmsg = lcmsg + crlf + crlf
	For lnI = 1 To lnAtchCnt
		If Adir(laFiles,laAtch[lnI])=0
*      ? "attachment "+ laAtch[lnI] + " not found, email failed."
			Inkey(1)
			Set Exact &exactstate
			Return .F.
		Endif

		lcAtch = dobase64Encode( laAtch[lnI] )

		contenttype = "application/octet-stream"
		If Upper(Justext(laAtch[lnI])) == "PDF"
			contenttype = "application/pdf"
		Endif
		newemailsegment =  crlf + "--MyUniqueEmailBoundary1" + crlf ;
			+ "Content-Type: " + contenttype + "; name=" + '"' + Justfname(laAtch[lnI]) + '"' + crlf ;
			+ "Content-Transfer-Encoding: base64"  + crlf ;
			+ 'Content-Disposition: attachment; filename="' + Justfname(laAtch[lnI]) + '"' + crlf + crlf

		lcmsg = lcmsg + newemailsegment + lcAtch

		lcAtch = '' && free memory
	Endfor
Endif

Local inlineimg
Local inlineimgpath
* add any inline content
inlinepos = At('src="cid:',lcmsg)
If inlinepos > 0
	inlineimg = Substr(lcmsg,inlinepos,100)
	inlineimg = Left(inlineimg,At('"',inlineimg,2))
	inlineimgpath = Substr(inlineimg,10,Len(inlineimg)-10)
	lcAtch = dobase64Encode( Alltrim(inlineimgpath) )
	contenttype = "application/octet-stream"
	If Upper(Justext(inlineimgpath)) == "PNG"
		contenttype = "image/png"
	Endif
	If Upper(Justext(inlineimgpath)) == "JPG"
		contenttype = "image/jpeg"
	Endif
	If Upper(Justext(inlineimgpath)) == "GIF"
		contenttype = "image/gif"
	Endif
	newemailsegment =  crlf + "--MyUniqueEmailBoundary1" + crlf ;
		+ "Content-Type: " + contenttype + crlf ;
		+ "Content-Transfer-Encoding: base64" + crlf ;
		+ "Content-ID: inlineimg1" + crlf ;
		+ "Content-Disposition: inline" + crlf + crlf

	newinlineimg = Strtran(inlineimg,inlineimgpath,"inlineimg1")
	lcmsg = Strtran(lcmsg,inlineimg,newinlineimg)
	lcmsg = lcmsg + newemailsegment + lcAtch
	lcAtch = '' && free memory
Endif

**STRTOFILE(lcMSG,"tempemail.txt")

Do While Type("sock") != "O"
	Sock=Create('mswinsock.winsock')
Enddo
Local cMsgIn

lnServPort = 25
lcServ = strServ
Do Case && Find Port
Case ':' $ lcServ
	lnAt = At(':',lcServ)
	lcServ = Left( lcServ, lnAt-1 )
	lnServPort = Val( Substr(lcServ, lnAt+1) )
	If lnServPort<=0
		lnServPort = 25
	Endif
Case ' ' $ lcServ
	lnAt = At(' ',lcServ)
	lcServ = Left( lcServ, lnAt-1 )
	lnServPort = Val( Substr(lcServ, lnAt+1) )
	If lnServPort<=0
		lnServPort = 25
	Endif
Endcase

Sock.RemoteHost = strServ
Sock.RemotePort = lnServPort

llRet = .F.
emailattempts = 0

Do While emailattempts < 20 && try up to 20 times

	emailattempts = emailattempts + 1

	Do While .T. && just a way of breaking out using exit on failed
		lnTime = Seconds()

		If Sock.State <> 7 && Connected
			Sock.Connect
			Do While Sock.State <> 7
				Inkey(0.1)
				If Seconds() - lnTime > TIME_OUT
					Exit && Leave Control Loop
				Endif
			Enddo
			Do While Sock.BytesReceived = 0
				Inkey(0.2)
				If Seconds() - lnTime > TIME_OUT
					Exit
				Endif
			Enddo
			cMsgIn = Repl(Chr(0),1000)
			Sock.GetData(@cMsgIn)
*    ? "connected"
*    ? cMsgIn
		Endif

*? "ehlo"
		If Not Readwrite(Sock,"EHLO ["+Alltrim(Sock.LocalIP)+"]", 250)
			Exit && Leave Control Loop
		Endif

		If username != ""
*? "authlogin"
			If Not Readwrite(Sock,"AUTH LOGIN", 334)
				Exit && Leave Control Loop
			Endif



*? "user"

			If Not Readwrite(Sock,username, 334)
				Exit && Leave Control Loop
			Endif


*? "pass"

			If Not Readwrite(Sock,pword, 235)
				? "FAILED TO AUTHENTICATE"
				Exit && Leave Control Loop
			Endif


		Endif

*? "mailfrom"

		If Not Readwrite(Sock,"MAIL FROM: " + Alltrim(strFrom), 250)
			Exit
		Endif

		lnCnt = Alines(laTO, Chrtran(emailTo,' ,;',Chr(13)+Chr(13)+Chr(13)))
*  ? str(lncnt)
* once for each email address
		For lnI = 1 To lnCnt
			If Not Empty(laTO[lnI])
				lcTo = 'rcpt to: <'+Alltrim(laTO[lnI])+'>'
*  		? lcTo
				If Not  Readwrite(Sock,lcTo,250)
					Exit && Leave Control Loop
				Endif
			Endif
		Endfor

*? "about to send data"
		If Not Readwrite(Sock,"DATA", 354)
			Exit && Leave Control Loop
		Endif

		lcOutStr = "DATE: " + GetSMTPDateTime() + crlf;
			+ "FROM: " + Alltrim(replyto) + crlf ;
			+ "TO: " + Alltrim(emailTo) + crlf ;
			+ "SUBJECT: " + Alltrim(strSubj) + crlf  ;
			+ "MIME-Version: 1.0" + crlf ;
			+ 'Content-Type: multipart/mixed; boundary="MyUniqueEmailBoundary1"' +  crlf  +  crlf;
			+ "--MyUniqueEmailBoundary1" + crlf
		If "" $ Upper(lcmsg)
			lcOutStr = lcOutStr + "Content-Type: text/html"  + crlf
		Else
			lcOutStr = lcOutStr + "Content-Type: text/plain"  + crlf
		Endif
		lcOutStr = lcOutStr + "Content-Transfer-Encoding: 8bit"  + crlf ;
			+ crlf ;
			+ lcmsg ;
			+ crlf ;
			+ "--MyUniqueEmailBoundary1--"

* ? lcmsg

* remove any inadvertant end-of-data marks:
		lcOutStr = Strtran(lcOutStr, crlf+'.'+crlf, crlf+'. '+crlf)
* Place end of data mark on end:
		lcOutStr = lcOutStr + crlf + "."

*? "transmit email"

		If Not Readwrite(Sock,lcOutStr, 250)
			Exit && Leave Control Loop
		Endif

		Sock.SendData( "QUIT" + crlf )

		llRet = .T.

		Exit

	Enddo

	If llRet == .T.
		Exit && Leave Control Loop
	Endif

Enddo

If llRet = .T.
* Do cleanup code.
	Junk = Repl(Chr(0),1000)
	If Sock.State = 7 && Connected
		Sock.GetData(@Junk)
	Endif
Endif
Sock.Close
Sock = .Null.

Set Exact &exactstate
Return llRet
Endfunc


*********************************************************************************
Function GetTimeZone( pcFunc )
* Purpose: Return the Time Zone bias or description
* Input: pcFunc = "BIAS" or Missing... return the bias in Minutes
* ( GMT = LocalTime + Bias )
* pcFunc = "NAME" ... Return the time zone name.
* Author: William GC Steinford
*******************************
lcTZInfo = num2dword(0);
	+Repl(Chr(0),64)+Repl(num2Word(0),8)+num2dword(0);
	+Repl(Chr(0),64)+Repl(num2Word(0),8)+num2dword(0)
Declare Integer GetTimeZoneInformation In kernel32.Dll;
	STRING @ lpTimeZoneInformation
#Define TIME_ZONE_ID_STANDARD 1
#Define TIME_ZONE_ID_DAYLIGHT 2
lcRes = GetTimeZoneInformation( @lcTZInfo )
lnBias = Buf2DWord( lcTZInfo )
lcDesc = "Unknown"
If lcRes > 0
	Do Case
	Case lcRes=TIME_ZONE_ID_STANDARD
		lcDesc = Substr( lcTZInfo, 3, 64 )
	Case lcRes=TIME_ZONE_ID_DAYLIGHT
		lcDesc = Substr( lcTZInfo, 89, 64 )
		lnBias = lnBias + Buf2DWord(Substr(lcTZInfo, 169, 4)) - 2 ^ 32
	Endcase
	lcDesc = Strconv( lcDesc, 6 ) && 6=Unicode(wide)->DoubleByte
	lcDesc = Strtran( lcDesc, Chr(0), '' )
Endif
If Vartype(pcFunc)='C' And pcFunc='NAME'
	Return lcDesc
Endif
Return lnBias
Endfunc

*********************************************************************************
Function GetSMTPDateTime
* Wed, 12 Mar 2003 07:54:56 -0500
Local lcRet, ltDT, lnBias
ltDT = Datetime()
If 'UTIL' $ Set('PROC')
	lnBias = GetTimeZone('BIAS') && In Util.prg
Else
	lnBias = -5 && EST
Endif
lcBias = Iif( lnBias<0, '+', '-' )
lnBias = Abs(lnBias)
lcBias = lcBias+Padl(Tran(lnBias/60),2,'0')+Padl(Tran(lnBias%60),2,'0')
lcRet = Left( Cdow(ltDT), 3 )+', '+Str( Day(ltDT), 2 ) + ' ' + Left( Cmonth(ltDT), 3);
	+' '+Tran( Year(ltDT) )+' '+Padl(Tran(Hour(ltDT)),2,'0')+':';
	+Padl(Tran(Minute(ltDT)),2,'0')+':';
	+Padl(Tran(Sec(ltDT)),2,'0')+' ';
	+lcBias
Return lcRet
Endfunc
* * *
* dword is compatible with LONG
Function num2Long( lnValue )
Return num2dword(lnValue)
Endfunc
Function num2dword (lnValue)
#Define m0 256
#Define m1 65536
#Define m2 16777216
Local b0, b1, b2, b3
b3 = Int(lnValue/m2)
b2 = Int((lnValue - b3*m2)/m1)
b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
b0 = Mod(lnValue, m0)
Return Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
Endfunc
* * *
* word is compatible with Integer
Function num2Word (lnValue)
Return Chr(Mod(m.lnValue,256)) + Chr(Int(m.lnValue/256))
Endfunc
* * *
Function buf2word (lcBuffer)
Return Asc(Substr(lcBuffer, 1,1)) + ;
	Asc(Substr(lcBuffer, 2,1)) * 256
Endfunc
* * *
Function buf2Long (lcBuffer)
Return Buf2DWord(lcBuffer)
Endfunc
Function Buf2DWord(lcBuffer)
Return Asc(Substr(lcBuffer, 1,1)) + ;
	Asc(Substr(lcBuffer, 2,1)) * 256 +;
	Asc(Substr(lcBuffer, 3,1)) * 65536 +;
	Asc(Substr(lcBuffer, 4,1)) * 16777216
Endfunc


*********************************************************************************
Function dobase64Encode(tcInFile)

Declare String EncodeBase64 In Base64_Library.Dll String, String, Integer
Local lcguid
Local lcoutfile
Local lcoutfname
lcoutfile = ""
lcguid = GetGUID()
If !Empty(lcguid)
	If !File("BASE64TEMP\base64temp"+Alltrim(lcguid)+".txt") && belt and braces
		lcoutfname = "BASE64TEMP\base64temp"+Alltrim(lcguid)+".txt"
		b64File = EncodeBase64(tcInFile,lcoutfname,76)
		If b64File != ""
			lcoutfile = Filetostr(lcoutfname)
			Erase (lcoutfname)
		Endif
	Endif
Endif

Return lcoutfile


*********************************************************************************
Function GetGUID()
Local lcBuffer, ;
	lcReturnValue, ;
	llNoClear, ;
	lnFuncVal

*-- Define local variables
lcBuffer      = Replicate( Chr( 0 ), 256 )
lcReturnValue = []
llNoClear     = Iif( Pcount() > 0 And Vartype( tlNoClear ) = "L", ;
	tlNoClear, ;
	.F. ;
	)
lnFuncVal     = 0

*-- Declare DLL functions
Declare Integer CoCreateGuid ;
	IN Ole32.Dll ;
	STRING @pGuid
Declare Integer StringFromGUID2 ;
	IN Ole32.Dll ;
	STRING rguid, String @lpsz, Integer cchMax

*-- Initialize a buffer to hold the GUID value
pGuid = Replicate( Chr( 0 ), 17 )

*-- Call the CoCreateGuid function
lnFuncVal = CoCreateGuid( @pGuid )

*-- If the DLL function returned zero,
*-- the function was successful,
*-- so build a string of the GUID data
If lnFuncVal = 0
	= StringFromGUID2( pGuid, @lcBuffer, 128 )

*-- Truncate the GUID string to the desired length
	lcBuffer = Substr( lcBuffer, ;
		1, ;
		AT( Chr( 0 ) + Chr( 0 ), lcBuffer ) ;
		)

*-- Convert the string
	lcReturnValue = Strconv( lcBuffer, 6 )

Endif && lnFuncVal = 0

*-- Unless the calling module chose not to,
*-- clear the instantiated DLLs from memory
If !llNoClear
	Clear Dlls "StringFromGUID2"
	Clear Dlls "CoCreateGuid"

Endif && !tlNoClear
*-- Clean up and return
Return ( lcReturnValue )


*********************************************************************************
Function Readwrite(oSock, cMsgOut, iExpectedCode)

Local cMsgIn, iCode, lnTime, iemax
iemax = iExpectedCode + 200
lnTime = Seconds()

oSock.SendData( cMsgOut + crlf )

Do While oSock.BytesReceived = 0
	Inkey(0.2)
	If Seconds() - lnTime > TIME_OUT
		Return .F.
	Endif
Enddo

cMsgIn = Repl(Chr(0),1000)
oSock.GetData(@cMsgIn)
iCode = Val(Left(cMsgIn, 3))
If iCode == iExpectedCode &&and iCode <= iemax
	Return .T.
ELSE
&& show the code that failed
		? cmsgout && Mike - this is msgout to show the failed request, icode below is the returned error number
		? iexpectedcode
		? icode
	Return .F.
Endif
Endfunc

Hope this helps you all.

Ken Sands. kensands@dsigroup.com


There is a typo in your MIME Content-Type boundary setting: the dashes should not be there.

lcoutstr = "DATE: " + getsmtpdatetime() + crlf;
				+ "FROM: " + ALLTRIM(replyto) + crlf ;
				+ "TO: " + ALLTRIM(emailto) + crlf ;
				+ "SUBJECT: " + ALLTRIM(strsubj) + crlf ;
				+ "MIME-Version: 1.0" + crlf ;
				+ 'Content-Type: multipart/mixed; boundary="UniqueEmailBoundary1";' + crlf ;
				+ "--UniqueEmailBoundary1" + crlf

-Barry Dempsey

---

Thanks Barry, it was one of those mistakes you introduce when trying to remove all the non generic bits that relate to your company (it used to be "mycompanynameboundary"). I'll sort it in the main code section.

-Ken

I've made another ammend there, the boundary line should not end with a semicolon, surprisingly it's been running for over a year now and we've only just had an email cause issues due to this, and it was connected with it getting processed trough a email scanner. anyway, thats now correct.

- Ken

I don't mean to be critical, but all this strikes me as needlessly complex. Why not just use something like CDO? Here's a link to a free zipped package of VFP CDO forms and classes that handles everything from simple plain text emails to HTML emails with attachments and embedded graphics.

- Sam Thornton

CDO also doesn't work half the time, gets messed around with security issues and does not suit a slim automated system. it's based on that computers outlook settings, so how do you send email via different email servers, or using different accounts? and what happens when outlook gets an automatic update restricting the cdo interface yet again? for those reasons CDO is not always a good solution. when setting up a system to send emails in a production environment this works a lot better, at least in my experience. My version also includes options of html, plaintext, or multipart, and attachments, I use all these options - Ken


Category Code Samples

- Simon Cropper

Has anyone managed to get a version of this program to work without WinSock?

I had the WinSock version working beautifully when following the instalation of a new AntiVirus Program (CA AntiVirus) and running SpyBot to get rid of some spyware, the program stopped working. Now I get the error "Class definition MSWINSOCK.WINSOCK is not found" mentioned above. One of these programs deregistered the WinSock and stuffed up the software. None of the program logs indicate what was done. I have removed all software but the error still happens.

I tried using vfpWinSock but Send SMTPEmail still returns a FALSE value.

OUTCOME of investigations...
1. inserting vfpWinSock class after the Send SMTPEmail.prg DID ACTUALLY WORK. The program just returned a false value.
2. working through the program with the debugger I found that the 'error' was due to the sock program not being able to quit while sending an encoded attachment. If you delay the program 20-30 seconds while the request is processed the quit command works.
3. for some reason this behaviour is only apparent when using the vfpWinSock class - MSWinSck.ocx did accepted the command without generating an error.
4. I have marked the relevant point to insert a delay in the above program.

---
Problem on sending multi receipants and attachments

I tried to use Sendsmtpemail, it works properly for single receipant and single attachment, but I want to send to multiple receipants with 2 or more attachement, it failed.
What should I do ?

thanks,
Edward (edwkong@gmail.com)

---
Send SMTPEmail has a parameter, oFB_Attachments, which allows multiple attachments. File names are separated by commas. See restrictions in comments at top of program. You can send multiple emails by creating a program that works through a table and calls Send SMTPEmail with the relevant parameters. Simon Cropper.

---
I send emails to mutiple recipients with multiple attachments no problem, are you using my version of the code? the last one on this page? - ken.

---

Hi Guys,

I recently encountered a problem, which I could use some hints in solving. I send a newsletter to about 150 of my clients using Send SMTPEmail - mailout program scans table of clients, uses Send SMTPEmail to send an email with PDF attachement, waits 40 seconds for the file to be encoded and sent, then moves onto the next client. Occassionally people emailed me that the file was corrupted and asked for me to resent the attachement. The second attempt always worked. They don't change their program or anything they do, nor do I, it is just that the second attempt isn't corrupted or something.

The last mailout resulted in about 10% of the 150 not working. Most complained that the file was coming as an mime-encoded inclusion and was not able to be displayed in the body of the text. I resend the file, either from my foxpro program or outlook, and they have no problem with getting the email or opening the attachment (PDF). It appears the second attempt has all the bits and flags inside the email in the right place. One person had Mail Marshall state that there could be a virus in the attachment. The file and attachement were clean.

I have emailed 120 copies of the same email and attachement to myself with my virus scanner on/off, outlook on/off and IE7 on/off. Despite trying I can't reproduce the problem.

Anyone got any ideas what might be happening here? It appears that the Send SMTPEmail does something that can be misinterpreted by different email programs.

I intend to ask everyone who has had a problem a range of questions about their system to try and identify the problem but I am not sure what I should be asking. Any guidance here would be helpful as well.

All the people that responded had Lotus Notes. It appears this program can do funny things with MIME-encoded data depending on the configuration, etc. What is confusing though is that if I send them emails from outlook they work. So as a work around I have flagged clients that report an error using the Send SMTPEmail program and save an email for them in Outlook using Office Automation. I can then go to Outlook and send the files manually. Not a big problem for a few people, but could be a pain for lots.

Simon Cropper

---

Simon, I was encountering a similar issue with email filter software causing issues at the point of scanning, I put something in to do with email boundries which fixed it, I'm not sure exactly what it was now though. is the problem occuring using the last version on this page that I put up? - Ken.

17/01/2008 -- After a long delay I finally worked through this problem and seem to have resolved this issue. I tried to run the last program on this page without any success -- problems with Winsock Registration. I was therefore required to modify my existing hybrid program that uses vfpWinSock. I correctly presumed, as mentioned by you, the problem would be in either the encoding routine or in delimiting of the attachments. I therefore went through the SendEmail program and compared it line-by-line to Send SMTPEmail program and modified these sections appropriately. It worked.

Simon Cropper

---

There is always "RCPT Failed" error when I send to single receipant
When I send a plain text email to single receiver, it always show "RCPT Failed", why ? please help !!
Edward

---

I was getting a "Error 501 5.0 ehlo requires domain address". Changing the line

IF NOT readwrite(sock,"EHLO", 250)

to

IF NOT readwrite(sock,"EHLO localhost", 250)

fixes the problem.

---

fixed an attachment semi bug the code should have been CHRTRAN not STRTRAN to sepatrate multiple attachments - Ken

---

Just as feedback for future users.

Take care when using these programs as they use !="" alot. As I found out through trial an error while trying to clarify why my email program suddenly stopped working -- !="" is not treated the same with SET EXACT ON and OFF.

For example, the IF b64file != "" command below is only positive if SET EXACT is ON; if OFF it is negative. I changed the command to IF NOT b64file == "" to get the correct result.

FUNCTION dobase64encode(tcinfile)

	DECLARE STRING EncodeBase64 IN Base64_Library.DLL STRING, STRING, INTEGER
	lcoutfile = ""
	b64file = encodebase64(tcinfile,"base64temp.txt",76)
	IF b64file != ""
		lcoutfile = FILETOSTR(b64file)
	ENDIF
	RETURN lcoutfile
ENDFUNC

Simon Cropper

---

Here is a peculiar issue that occurs in both my modified Send SMTPEmail() that uses vfpWinSock and the SendEmail() program listed at the bottom of this page that uses WinSock.

If you send an email message (no attachements) that is over 990 characters long something in the program cuts it up and inserts a carriage return followed by a space. I have tried to track down the culprit but it seems to be occurring in vfpWinSock and WinSock. My debugging indicates the message text is intact when handed to ReadWrite() to send.

To see what I mean, try sending 1111111111222222222233333333334444444444...(reiterate so you have several thouusand characters) to yourself. Look at an email.

Essentally what happens is that the initial segment is 990 characters followed by CHR(13)+" ", then 989 characters followed by CHR(13)+" ". The last 989 chunks are repeated over and over. No data seems to have gone missing, it is just that various words in my emails get spaces inserted in them. To date this has gone unnoticed in large text files but have become a problem in large HTML files due to hyperlinks and commands being broken into two parts.

Attachments seem to get sent without any problems.

Has anyone encountered this problem before? Anyone know what is going on?

Cheers Simon Cropper (scropper_AT_botanicus-aust.com.au)

27/02/2008 -- I have continued trying to debug this problem and found that it is not confined to SendEmail. Using the CDOEmail() functions from http://fox.wikis.com/wc.dll?Wiki~CdoEmail also generates the same problem. Files over 990 characters long are split into 990, then 989 sized, blocks separated by chr(13)+" ". It does not seem to matter whether the data is sent as HTML or TEXT. The fact that I get the problem whether I am using SendEmail()/CDOEmail() which uses Microsoft's WinSock or Send SMTPEmail() using vfpWinSock, I am pretty sure it is not the WinSock Library. The fact that I can send any sized email from Outlook without any problem also supports this. I am using Office2000 + XPPro SP2 + VFP9. Simon.

28/02/2008 -- Ken was unable to reproduce the error on his system so it appears that the issue is centred around my computer or ISP. Ken suggested it might have something to do with email spam filtering or virus scanning. I have turned off everything I could to no avail. What I did discover was that the problem occurs in all the programs I could find - BLAT, SendEmail, Send SMTPEmail and CDOEmail. It does not occur in Outlook. All use WinSock. The other interesting fact was that the problem only appears if the length of a string of characters between carriage returns in the email goes over the 990, 989, etc limit. That is, the problem only appears if you create a continuous string over 990 charcaters long. My work around is to insert CHR(13) where ever I can in my emails. Bye and bye, spaces don't count.

05/03/2008 -- I could not find util.prg (used in the code), so I reproduce how to get timezone from windows below. The good thing about putting this into your code is that it is one less dependency. Tony Wallace

FUNCTION getbias()
*| typedef struct _TIME_ZONE_INFORMATION {
*| LONG Bias; 0 4
*| WCHAR StandardName[ 32 ]; 4 64
*| SYSTEMTIME StandardDate; 68 16
*| LONG StandardBias; 84 4
*| WCHAR DaylightName[ 32 ]; 88 64
*| SYSTEMTIME DaylightDate; 152 16
*| LONG DaylightBias; 168 4
*| } TIME_ZONE_INFORMATION, *PTIME_ZONE_INFORMATION; total 172 bytes
#DEFINE TIME_ZONE_SIZE 172
DECLARE INTEGER Get Time Zone Information IN kernel32;
STRING @lpTimeZoneInformation

LOCAL cTimeZone, cTimeZone_, nId
cTimeZone = Repli(Chr(0), TIME_ZONE_SIZE)

nId = GetTimeZoneInformation(@cTimeZone)
RETURN buf2dword(SUBSTR(cTimeZone, 1,4))

ENDFUNC

FUNCTION buf2dword(lcBuffer)
RETURN Asc(SUBSTR(lcBuffer, 1,1)) + ;
BitLShift(Asc(SUBSTR(lcBuffer, 2,1)), 8) +;
BitLShift(Asc(SUBSTR(lcBuffer, 3,1)), 16) +;
BitLShift(Asc(SUBSTR(lcBuffer, 4,1)), 24)

[2009.05.16 10:07:09 AM GMT] Could anyone highlight the final workable version for usage ?!

I've only just notice the date thing myself, it was a few errors in the time code right from the original, I never looked into it because it didn't break the code it just put slightly incorrect send times into the emails.
I've fixed that now, there is no reference to UTILS and the daylight saving time bias works. again I've fixed it in the last full code example shown above. - Ken

I've also added guids to the temp filenames used in base64 encoding, this allows this code to be called multiple times without the tempfiles overlapping and sending the wrong attachments! code for the guid bit was taken from the wiki at http://fox.wikis.com/wc.dll?Wiki~GUIDGenerationCode
- Ken

Edit -Find- Recent Changes Categories Road Map [A-F] [G-P] [Q-Z] New Topic Home

Search:

http://fox.wikis.com - a low-impedance, fat-free Visual Foxpro site. - 2010.07.31 06:49:26 PM EST