Как сделать калькулятор в Delphi?

Delphi - объектно-ориентированный язык программирования, разработанный компанией Borland в 1995 году. Он основан на языке программирования Pascal, но имеет более расширенные возможности и добавлены новые функции.

Как Delphi реализует многоплатформенную разработку?

Delphi является интегрированной средой разработки (IDE), которая позволяет разрабатывать программное обеспечение для различных платформ, включая Windows, macOS, Android и iOS. Delphi достигает многоплатформенности с помощью...

Использование SMTP Relay Server

Советы » E-mail » Использование SMTP Relay Server

Использование SMTP Relay Server - отсылка письма напрямую минуя любые промежуточные сервера (пример взят из библиотеки Indy). Для отсылки письма с использованием компонентов Indy. Пример для Delphi 7 (скорее всего будет работать и в Delphi 6), для Kylix 3 нужны небольшие исправления для перевода в CLX приложение (сама функциональность та же). 

unit
 fMain;
interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP, IdComponent,
  IdUDPBase, IdUDPClient, IdDNSResolver, IdBaseComponent, IdMessage,
  StdCtrls, ExtCtrls, ComCtrls, IdAntiFreezeBase, IdAntiFreeze;
type

  TfrmMain = class
(TForm)
    IdMessage: TIdMessage;
    IdDNSResolver: TIdDNSResolver;
    IdSMTP: TIdSMTP;
    Label1: TLabel;
    sbMain: TStatusBar;
    Label2: TLabel;
    edtDNS: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    edtSender: TEdit;
    Label5: TLabel;
    edtRecipient: TEdit;
    Label6: TLabel;
    edtSubject: TEdit;
    Label7: TLabel;
    mmoMessageText: TMemo;
    btnSendMail: TButton;
    btnExit: TButton;
    IdAntiFreeze: TIdAntiFreeze;
    Label8: TLabel;
    edtTimeOut: TEdit;
    Label9: TLabel;
    Label10: TLabel;
    procedure
 btnExitClick(Sender: TObject);
    procedure
 btnSendMailClick(Sender: TObject);
  public

    fMailServers: TStringList;
    function
 PadZero(s: string
): string
;
    function
 GetMailServers: Boolean;
    function
 ValidData: Boolean;
    procedure
 SendMail; overload;
    function
 SendMail(aHost: string
): Boolean; overload;
    procedure
 LockControls;
    procedure
 UnlockControls;
    procedure
 Msg(aMessage: string
);
  end
;
var

  frmMain: TfrmMain;
implementation

{$R *.DFM}

procedure
 TfrmMain.btnExitClick(Sender: TObject);
begin

  application.terminate;
end
;

procedure
 TfrmMain.btnSendMailClick(Sender: TObject);
begin

  Msg('');
  LockControls;
  if
 ValidData then

    SendMail;
  UnlockControls;
  Msg('');
end
;

function
 TfrmMain.GetMailServers: Boolean;
var

  i, x: integer;
  LDomainPart: string
;
  LMXRecord: TMXRecord;
begin

  if
 not
 assigned(fmailServers) then

    fMailServers := TStringList.Create;
  fmailServers.clear;
  Result := true;
  with
 IdDNSResolver do

  begin

    QueryResult.Clear;
    QueryRecords := [qtMX];
    Msg('Setting up DNS query parameters');
    Host := edtDNS.text;
    ReceiveTimeout := StrToInt(edtTimeOut.text);
    // Extract the domain part from recipient email address
    LDomainPart := copy(edtRecipient.text, pos('@', edtRecipient.text) + 1,
      length(edtRecipient.text));
    // the domain name to resolve
    try

      Msg('Resolving DNS');
      Resolve(LDomainPart);
      if
 QueryResult.Count > 0 then

      begin

        for
 i := 0 to
 QueryResult.Count - 1 do

        begin

          LMXRecord := TMXRecord(QueryResult.Items[i]);
          fMailServers.Append(PadZero(IntToStr(LMXRecord.Preference)) + '=' +
            LMXRecord.ExchangeServer);
        end
;
        // sort in order of priority and then remove extra data
        fMailServers.Sorted := false;
        for
 i := 0 to
 fMailServers.count - 1 do

        begin

          x := pos('=', fMailServers.Strings[i]);
          if
 x > 0 then

            fMailServers.Strings[i] :=
              copy(fMailServers.Strings[i], x + 1,
                length(fMailServers.Strings[i]));
        end
;
        fMailServers.Sorted := true;
        fMailServers.Duplicates := dupIgnore;
        Result := true;
      end

      else

      begin

        Msg('No response from DNS server');
        MessageDlg('There is no response from the DNS server !', mtInformation,
          [mbOK], 0);
        Result := false;
      end
;
    except

      on
 E: Exception do

      begin

        Msg('Error resolving domain');
        MessageDlg('Error resolving domain: ' + e.message
, mtInformation,
          [mbOK], 0);
        Result := false;
      end
;
    end
;
  end
;
end
;
// Used in DNS preferance sorting

procedure
 TfrmMain.LockControls;
var

  i: integer;
begin

  edtDNS.enabled := false;
  edtSender.enabled := false;
  edtRecipient.enabled := false;
  edtSubject.enabled := false;
  mmoMessageText.enabled := false;
  btnExit.enabled := false;
  btnSendMail.enabled := false;
end
;

procedure
 TfrmMain.UnlockControls;
begin

  edtDNS.enabled := true;
  edtSender.enabled := true;
  edtRecipient.enabled := true;
  edtSubject.enabled := true;
  mmoMessageText.enabled := true;
  btnExit.enabled := true;
  btnSendMail.enabled := true;
end
;

function
 TfrmMain.PadZero(s: string
): string
;
begin

  if
 length(s) < 2 then

    s := '0' + s;
  Result := s;
end
;

procedure
 TfrmMain.SendMail;
var

  i: integer;
begin

  if
 GetMailServers then

  begin

    with
 IdMessage do

    begin

      Msg('Assigning mail message properties');
      From.Text := edtSender.text;
      Sender.Text := edtSender.text;
      Recipients.EMailAddresses := edtRecipient.text;
      Subject := edtSubject.text;
      Body := mmoMessageText.Lines;
    end
;
    for
 i := 0 to
 fMailServers.count - 1 do

    begin

      Msg('Attempting to send mail');
      if
 SendMail(fMailServers.Strings[i]) then

      begin

        MessageDlg('Mail successfully sent and available for pickup by recipient !',
          mtInformation, [mbOK], 0);
        Exit;
      end
;
    end
;
    // if we are here then something went wrong .. 
    // ie there were no available servers to accept our mail!
    MessageDlg('Could not send mail to remote server - please try again later.',
      mtInformation, [mbOK], 0);
  end
;
  if
 assigned(fMailServers) then

    FreeAndNil(fMailServers);
end
;

function
 TfrmMain.SendMail(aHost: string
): Boolean;
begin

  Result := false;
  with
 IdSMTP do

  begin

    Caption := 'Trying to sendmail via: ' + aHost;
    Msg('Trying to sendmail via: ' + aHost);
    Host := aHost;
    try

      Msg('Attempting connect');
      Connect;
      Msg('Successful connect ... sending message');
      Send(IdMessage);
      Msg('Attempting disconnect');
      Disconnect;
      msg('Successful disconnect');
      Result := true;
    except
 on
 E: Exception do

      begin

        if
 connected then

        try

          disconnect;
        except

        end
;
        Msg('Error sending message');
        result := false;
        ShowMessage(E.Message
);
      end
;
    end
;
  end
;
  Caption := '';
end
;

function
 TfrmMain.ValidData: Boolean;
var

  ErrString: string
;
begin

  Result := True;
  ErrString := '';
  if
 trim(edtDNS.text) = '' then

    ErrString := ErrString + #13 + '»'  + 'DNS server not filled in';
  if
 trim(edtSender.text) = '' then

    ErrString := ErrString + #13 + '»'  + 'Sender email not filled in';
  if
 trim(edtRecipient.text) = '' then

    ErrString := ErrString + #13 + '»'  + 'Recipient not filled in';
  if
 ErrString <> '' then

  begin

    MessageDlg('Cannot proceed due to the following errors:' + #13 + #10 +
      ErrString, mtInformation, [mbOK], 0);
    Result := False;
  end
;
end
;

procedure
 TfrmMain.Msg(aMessage: string
);
begin

  sbMain.SimpleText := aMessage;
  application.ProcessMessages;
end
;

end
.

Форма для модуля: 

object
 frmMain: TfrmMain
   Left = 243
   Top = 129
   Width = 448
   Height = 398
   Caption = 'INDY - SMTP Relay Demo'
   Color = clBtnFace
   Font.Charset = DEFAULT_CHARSET
   Font.Color = clWindowText
   Font.Height = -11
   Font.Name = 'MS Sans Serif'
   Font.Style = []
   OldCreateOrder = False
   PixelsPerInch = 96
   TextHeight = 13
   object
 Label1: TLabel
     Left = 7
     Top = 8
     Width = 311
     Height = 26
     Caption =
        'Demonstrates sending mail directly to a users mailbox on a remot' +
       'e mailserver - this negates the need for a local SMTP server'
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clGray
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     ParentFont = False
     WordWrap = True
   end

   object
 Label2: TLabel
     Left = 8
     Top = 64
     Width = 111
     Height = 13
     Caption = 'DNS server IP address:'
   end

   object
 Label3: TLabel
     Left = 8
     Top = 123
     Width = 104
     Height = 13
     Caption = 'Sender email address:'
   end

   object
 Label4: TLabel
     Left = 288
     Top = 64
     Width = 49
     Height = 13
     Caption = 'Required !'
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clGray
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     ParentFont = False
   end

   object
 Label5: TLabel
     Left = 8
     Top = 150
     Width = 115
     Height = 13
     Caption = 'Recipient email address:'
   end

   object
 Label6: TLabel
     Left = 8
     Top = 177
     Width = 72
     Height = 13
     Caption = 'Subject of mail:'
   end

   object
 Label7: TLabel
     Left = 8
     Top = 204
     Width = 66
     Height = 13
     Caption = 'Message text:'
   end

   object
 Label8: TLabel
     Left = 8
     Top = 91
     Width = 95
     Height = 13
     Caption = 'DNS server timeout:'
   end

   object
 Label9: TLabel
     Left = 336
     Top = 124
     Width = 49
     Height = 13
     Caption = 'Required !'
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clGray
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     ParentFont = False
   end

   object
 Label10: TLabel
     Left = 336
     Top = 148
     Width = 49
     Height = 13
     Caption = 'Required !'
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clGray
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     ParentFont = False
   end

   object
 sbMain: TStatusBar
     Left = 0
     Top = 352
     Width = 440
     Height = 19
     Panels = <>
   end

   object
 edtDNS: TEdit
     Left = 128
     Top = 60
     Width = 153
     Height = 21
     TabOrder = 1
   end

   object
 edtSender: TEdit
     Left = 128
     Top = 119
     Width = 205
     Height = 21
     TabOrder = 2
   end

   object
 edtRecipient: TEdit
     Left = 128
     Top = 146
     Width = 205
     Height = 21
     TabOrder = 3
   end

   object
 edtSubject: TEdit
     Left = 128
     Top = 173
     Width = 205
     Height = 21
     TabOrder = 4
   end

   object
 mmoMessageText: TMemo
     Left = 128
     Top = 200
     Width = 205
     Height = 113
     TabOrder = 5
   end

   object
 btnSendMail: TButton
     Left = 258
     Top = 321
     Width = 75
     Height = 25
     Caption = 'Send mail !'
     TabOrder = 6
     OnClick = btnSendMailClick
   end

   object
 btnExit: TButton
     Left = 356
     Top = 8
     Width = 75
     Height = 25
     Caption = 'E&xit'
     TabOrder = 7
     OnClick = btnExitClick
   end

   object
 edtTimeOut: TEdit
     Left = 128
     Top = 87
     Width = 61
     Height = 21
     TabOrder = 8
     Text = '5000'
   end

   object
 IdMessage: TIdMessage
     AttachmentEncoding = 'MIME'
     BccList = <>
     CCList = <>
     Encoding = meMIME
     Recipients = <>
     ReplyTo = <>
     Left = 12
     Top = 236
   end

   object
 IdDNSResolver: TIdDNSResolver
     Port = 53
     ReceiveTimeout = 60
     QueryRecords = []
     Left = 12
     Top = 268
   end

   object
 IdSMTP: TIdSMTP
     MaxLineAction = maException
     ReadTimeout = 0
     Port = 25
     AuthenticationType = atNone
     Left = 12
     Top = 204
   end

   object
 IdAntiFreeze: TIdAntiFreeze
     Left = 12
     Top = 300
   end

 end

Другое по теме:

Категории

Статьи

Советы

Copyright © 2024 - All Rights Reserved - www.delphirus.com