'===========================================================================
' Subject: SMTP EXAMPLE FOR PB/DLL 6.0        Date: 05-24-99 (17:34)       
'  Author: Dave Navarro, Jr.                  Code: PBDLL                  
'  Origin: dave@powerbasic.com              Packet: PBDLL.ABC
'===========================================================================
'==============================================================================
'
'  SMTP example for PB/DLL 6.0
'  Copyright (c) 1999 PowerBASIC, Inc.
'
'==============================================================================

#COMPILE EXE
#INCLUDE "WIN32API.INC"

'------------------------------------------------------------------------------

$mailhost = "pop.yourserver.com"
$mailfrom = "Your Name <address@yourserver.com>"

GLOBAL hServer  AS LONG
GLOBAL hFrom    AS LONG
GLOBAL hTo      AS LONG
GLOBAL hSubject AS LONG
GLOBAL hMessage AS LONG
GLOBAL hDlgMain AS LONG

'------------------------------------------------------------------------------

FUNCTION MakeFont(BYVAL Font AS STRING, BYVAL PointSize AS LONG) AS LONG

  LOCAL hDC      AS LONG
  LOCAL CyPixels AS LONG

  hDC = GetDC(%HWND_DESKTOP)
  CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
  ReleaseDC %HWND_DESKTOP, hDC

  PointSize = (PointSize * CyPixels) \ 72

  FUNCTION = CreateFont(0 - PointSize, 0, 0, 0, %FW_NORMAL, 0, 0, 0, _
            %ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
            %DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY Font)

END FUNCTION

'------------------------------------------------------------------------------

FUNCTION SendMail() AS LONG

  LOCAL Msg       AS STRING
  LOCAL Buffer    AS STRING
  LOCAL localhost AS STRING
  LOCAL hTcp      AS LONG
  LOCAL position  AS LONG
  LOCAL length    AS LONG
  LOCAL hCursor   AS LONG

  IF GetWindowTextLength(hServer) = 0 OR _
     GetWindowTextLength(hFrom) = 0 OR _
     GetWindowTextLength(hTo) = 0 THEN
    MsgBox "One or more of the required fields is empty.",,"Data Error!"
    GOTO Done
  END IF

  MOUSEPTR 11

' ** Get the local host name
  HOST ADDR TO hTCP
  HOST NAME hTCP TO localhost

' ** Connect to mail server
  DIALOG DOEVENTS
  hTCP = FREEFILE
  CONTROL GET TEXT hDlgMain, 101 TO Buffer
  TCP OPEN "smtp" AT Buffer AS hTCP
  IF ERR THEN
    Buffer = "Error connecting to mailhost"
    GOTO SendError
  ELSE
    TCP LINE hTCP, Buffer
    IF LEFT$(Buffer, 3) <> "220" THEN
      GOTO SendError
    END IF
  END IF

' ** Greet the mailhost
  DIALOG DOEVENTS
  TCP PRINT hTCP, "HELO " + localhost
  TCP LINE hTCP, Buffer
  IF LEFT$(Buffer, 3) <> "250" THEN
    Buffer = "HELO error: " + Buffer
    GOTO SendError
  END IF

' ** Tell the mailhost who we are
  DIALOG DOEVENTS
  CONTROL GET TEXT hDlgMain, 102 TO Buffer
  REGEXPR "[a-zA-Z0-9._]+@[a-zA-Z0-9._]+" IN Buffer TO position, length
  IF length = 0 THEN
    Buffer = "Invalid FROM email address"
    GOTO SendError
  ELSE
    Buffer = MID$(Buffer, position, length)
  END IF

  DIALOG DOEVENTS
  TCP PRINT hTCP, "MAIL FROM: <" + Buffer + ">"
  TCP LINE hTCP, Buffer
  IF LEFT$(Buffer, 3) <> "250" THEN
    Buffer = "MAIL FROM error: " + Buffer
    GOTO SendError
  END IF

' ** Tell the mailhost who the message is for
  DIALOG DOEVENTS
  CONTROL GET TEXT hDlgMain, 103 TO Buffer
  REGEXPR "[a-zA-Z0-9._]+@[a-zA-Z0-9._]+" IN Buffer TO position, length
  IF length = 0 THEN
    Buffer = "Invalid TO email address"
    GOTO SendError
  ELSE
    Buffer = MID$(Buffer, position, length)
  END IF

  DIALOG DOEVENTS
  TCP PRINT hTCP, "RCPT TO: <" + Buffer + ">"
  TCP LINE hTCP, Buffer
  IF LEFT$(Buffer, 3) <> "250" THEN
    Buffer = "RCPT TO error: " + Buffer
    GOTO SendError
  END IF

' ** Send the message
  DIALOG DOEVENTS
  TCP PRINT hTCP, "DATA"
  TCP LINE hTCP, Buffer
  IF LEFT$(Buffer, 3) <> "354" THEN
    Buffer = "DATA error: " + Buffer
    GOTO SendError
  END IF

  CONTROL GET TEXT hDlgMain, 102 TO Buffer
  TCP PRINT hTCP, "From: " + Buffer

  CONTROL GET TEXT hDlgMain, 103 TO Buffer
  TCP PRINT hTCP, "To: " + Buffer

  CONTROL GET TEXT hDlgMain, 104 TO Buffer
  IF LEN(Buffer) THEN
    TCP PRINT hTCP, "Subject: " + Buffer
  END IF

  TCP PRINT hTCP, "X-Mailer: PowerBASIC SMTP example v1.0"

  CONTROL GET TEXT hDlgMain, 105 TO Msg
  REPLACE CHR$(13,10) WITH CHR$(13) IN Msg
  WHILE LEN(Msg)
    Buffer = EXTRACT$(Msg, CHR$(13))
    IF ASC(Buffer) = 46 THEN
      Buffer = "." + Buffer
    END IF
    TCP PRINT hTCP, Buffer
    Msg = MID$(Msg, LEN(Buffer)+2)
  WEND

  TCP PRINT hTCP, "."
  TCP LINE hTCP, Buffer
  IF LEFT$(Buffer, 3) <> "250" THEN
    GOTO SendError
  END IF

' ** Say goodbye
  TCP PRINT hTCP, "QUIT"
  TCP LINE hTCP, Buffer
  IF LEFT$(Buffer, 3) <> "221" THEN
    Buffer = "QUIT error: " + Buffer
    GOTO SendError
  END IF

  TCP CLOSE hTCP

  FUNCTION = -1

Done:
  MOUSEPTR 0
  SetFocus hDlgMain
  EXIT FUNCTION

SendError:
  TCP CLOSE hTCP
  MsgBox Buffer,, "SMTP Error"
  GOTO Done

END FUNCTION

'------------------------------------------------------------------------------

CALLBACK FUNCTION DlgProc () AS LONG

  STATIC hFont    AS LONG

  IF CBMSG = %WM_INITDIALOG THEN

    CONTROL HANDLE hDlgMain, 101 TO hServer
    CONTROL HANDLE hDlgMain, 102 TO hFrom
    CONTROL HANDLE hDlgMain, 103 TO hTo
    CONTROL HANDLE hDlgMain, 104 TO hSubject
    CONTROL HANDLE hDlgMain, 105 TO hMessage

    CONTROL SET TEXT hDlgMain, 101, $mailhost
    CONTROL SET TEXT hDlgMain, 102, $mailfrom

    hFont     = MakeFont("Courier New", 10)
    CONTROL SEND hDlgMain, 105, %WM_SETFONT,hFont, 1

    CONTROL SET FOCUS hDlgMain, 103

    FUNCTION = 1

  END IF

END FUNCTION

'------------------------------------------------------------------------------

CALLBACK FUNCTION CancelButton() AS LONG

  DIALOG END hDlgMain, 0
  FUNCTION = 1

END FUNCTION

'------------------------------------------------------------------------------

CALLBACK FUNCTION OkButton() AS LONG

  LOCAL s AS STRING

  CONTROL GET TEXT hDlgMain, 105 TO s
  IF LEN(s) = 0 THEN
    SetFocus hMessage
    EXIT FUNCTION
  ELSEIF SendMail THEN
    MsgBox "Your email message was successfully sent.",,"Success!"
    DIALOG END hDlgMain, 1
    FUNCTION = 1
  END IF

END FUNCTION

'------------------------------------------------------------------------------

FUNCTION PbMain () AS LONG

  DIALOG NEW 0, "Simple Mail Transfer Protocol (SMTP)", ,, 365, 250, 0, 0 TO hDlgMain

  CONTROL ADD LABEL, hDlgMain, -1, "Server:",  17, 11, 40, 8, %SS_RIGHT
  CONTROL ADD LABEL, hDlgMain, -1, "From:",    17, 24, 40, 8, %SS_RIGHT
  CONTROL ADD LABEL, hDlgMain, -1, "To:",      17, 36, 40, 8, %SS_RIGHT
  CONTROL ADD LABEL, hDlgMain, -1, "Subject:", 17, 50, 40, 8, %SS_RIGHT

  CONTROL ADD TEXTBOX, hDlgMain, 101, "", 60,  9, 299,  12, %ES_AUTOHSCROLL OR %WS_BORDER, %WS_EX_CLIENTEDGE
  CONTROL ADD TEXTBOX, hDlgMain, 102, "", 60, 22, 299,  12, %ES_AUTOHSCROLL OR %WS_BORDER, %WS_EX_CLIENTEDGE
  CONTROL ADD TEXTBOX, hDlgMain, 103, "", 60, 35, 299,  12, %ES_AUTOHSCROLL OR %WS_BORDER, %WS_EX_CLIENTEDGE
  CONTROL ADD TEXTBOX, hDlgMain, 104, "", 60, 48, 299,  12, %ES_AUTOHSCROLL OR %WS_BORDER, %WS_EX_CLIENTEDGE
  CONTROL ADD TEXTBOX, hDlgMain, 105, "",  6, 66, 353, 161, %ES_AUTOHSCROLL OR %ES_AUTOVSCROLL OR %ES_MULTILINE OR %ES_WANTRETURN OR %WS_BORDER, %WS_EX_CLIENTEDGE

  CONTROL ADD BUTTON, hDlgMain, %IDOK,     "&Send",   275, 232, 40, 14, %BS_DEFPUSHBUTTON CALL OkButton
  CONTROL ADD BUTTON, hDlgMain, %IDCANCEL, "&Cancel", 319, 232, 40, 14, 0 CALL CancelButton

  DIALOG SHOW MODAL hDlgMain CALL DlgProc

END FUNCTION