-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathmail2000.pas
7349 lines (5398 loc) · 170 KB
/
mail2000.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
//本文件为 clq 修改自 TMail2000 控件,修改只涉及编解码部分,通讯部分并没有用它
//目前最新代码位于 https://github.com/clqsrc/delphi_lost
// 2019/7/24 21:56:42 增加了一个邮件 mime 各个部分的未解码字符集的原始字符串属性，因为 utf-8 的 html 显示时需要。参考 self.Decoded_Bin 相关代码
// 2019/7/31 19:53:11 GetTimeZoneBias: Double; //这个函数实际上是得到 delphi 的小时数值的表示//1 就表示 24 个小时，所以要得到 8 小时的 delphi tdatetime 值就是 8 除以 24
(*
Component name...................: Mail2000 (Mail2000.pas)
Classes implemented..............: TPOP2000, TSMTP2000, TMailMessage2000
Version..........................: 1.9.5
Status...........................: Beta
Last update......................: 2001-08-02
Author...........................: Marcello 'Panda' Tavares
Homepage.........................: http://groups.yahoo.com/group/tmail2000
Comments, bugs, suggestions to...: [email protected]
Language.........................: English
Platform (tested)................: Windows 95/98/98SE/2000
Requires.........................: Borland Delphi 5 Professional or better
Features
--------
1. Retrieve and delete messages from POP3 servers;
2. Send messages through SMTP servers;
3. Parse MIME or UUCODE messages in header, body, alternative texts and
attachments;
4. Create or modify MIME messages on-the-fly;
5. HTML and embedded graphics support;
6. Save or retrieve messages or attachments from files or streams;
7. Ideal for automated e-mail processing.
Know limitations
----------------
1. Does not build UUCODE messages;
2. Some problems when running on Windows NT/2000/ME (worth a try);
3. Strange behaviours when netlink not present;
4. Some troubles when handling very big messages;
5. New messages will always be multipart;
6. Some bugs and memory leaks.
How to install
--------------
Create a directory;
Extract archive contents on it;
Open Delphi;
Click File/Close All;
Click Component/Install Component;
In "Unit File Name" select mail2000.pas;
Click Ok;
Select Yes to rebuild package;
Wait for the message saying that the component is installed;
Click File/Close All;
Select Yes to save the package;
Now try to run the demo.
How to use
----------
The better way to learn is playing with the demo application.
I'm not planning to type a help file.
Fell free to mail your questions to me, expect aswer for 1-2 weeks.
See 'Discussion Group' section below.
Good luck!
License stuff
-------------
Mail2000 Copyleft 1999-2001
This software is provided as-is, without any express or implied
warranty. In no event will the author be held liable for any damages
arising from the use of this software.
As a freeware, the author reserve your rights to not provide support,
requested changes in the code, specific versions, improvements of any
kind and bug fixes. The main purpose is to help a little the programmers
community over the world as a whole, not just one person or organization.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented, you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being an original software.
3. If you make changes to this software, you must send me the modified
integral version.
Please, consider my hard work.
Thanks to
---------
Mariano D. Podesta ([email protected]) - The author of wlPop3
component, from where I copied some decoding routines;
Sergio Kessler ([email protected]) - The author of SakEmail
component, from where I based my encoding and smtp algorithms;
Delphi Super Page (http://delphi.icm.edu.pl) - For providing
the best way to find great programs and to join the Delphi community;
Yunarso Anang ([email protected]) - For providing some functions for
correct threatment of oriental charsets;
Christian Bormann ([email protected]) - For giving a lot of suggestions
and hard testing of this component;
Tommy Andersen (sorry, I lost his address) - For warning about some
bugs in code;
Kunikazu Okada ([email protected]) - For detailed and careful suggestions
to help mail composition;
Anderson ([email protected]) - Advices;
Rene de Jong ([email protected]) - Extensive bugfixes;
Hou Yg ([email protected]) - Improvements;
Peter Baars ([email protected]) - Bugfixes;
Giuseppe Mingolla ([email protected]) - AttachStream method;
Milkopb ([email protected]) - Bugfixes;
David P. Schwartz ([email protected]) - Code fixes;
Anyone interested in helping me to improve this component, including you,
just by downloading it.
What's new in 1.1 version
-------------------------
1. Fixed the threatment of encoded fields in header;
2. Fixed some fake attachments found in message;
3. Included a string property "LastMessage" containing the source of
last message retrieved;
4. Now decoding file names;
5. Fixed way to identify kind of host address;
6. Added support for some tunnel proxy servers (eg via telnet port);
7. Socket changed to non-blocking to improve communication;
8. Fixed crashes when decoding encoded labels;
9. Fixed header decoding with ansi charsets;
10. Fixed crashes when there are deleted messages on server;
11. Now recognizing text/??? file attachments;
12. Added Content-ID label at attachment header, now you can reference
attached files on HTML code as <img src=cid:file.ext>;
13. Improved a lot the speed when decoding messages;
14. Thousands of minor bug fixes.
What's new in 1.2 version
-------------------------
1. Added HELO command when talking to SMTP server;
2. Changed CCO: fields (in portuguese) to BCC:
3. It doesn't remove BCC: field after SMTP send anymore;
4. Some random bugs fixed.
What's new in 1.3 version
-------------------------
1. POP and SMTP routines discontinued, but they will remain in the code;
2. Some suggestions added.
What's new in 1.4 version
-------------------------
1. Improved UUCODE decoding;
2. Range overflow bugs fixed;
3. Changed MailMessage to MailMessage2000 to avoid class name conflicts.
What's new in 1.5 version
-------------------------
1. I decided to improve POP and SMTP, but still aren't reliable;
2. Another sort of bug fixes;
3. TPOP2000.RetrieveHeader procedure added;
4. TPOP2000.DeleteAfterRetrieve property added;
5. Improved threatment of messages with no text parts;
6. Proxy support will remain, but has been discontinued;
7. TMailMessage2000.LoadFromFile procedure added;
8. TMailMessage2000.SaveToFile procedure added.
What's new in 1.6 version
-------------------------
1. Fixed expecting '+OK ' instead of '+OK' from SMTP;
2. Stopped using TClientSocket.ReceiveLength, which is innacurate.
What's new in 1.7 version
-------------------------
1. Handling of 'Received' (hop) headers. Now it is possible to trace the
path e-mail went on;
2. Again, bug fixes;
3. Added properties to read (and just to read) 'To:' information and 'Cc:'
information using TStringList;
4. Added procedures to set destinations in comma-delimited format;
5. Removed text/rtf handling.
What's new in 1.8 version
-------------------------
1. Guess what? Bug fixes;
2. Some memory leaks identified and fixed;
3. Improved SMTP processing;
4. Exception fixed in function 'Fill';
5. Added 'AttachStream' method.
What's new in 1.9.x version
-------------------------
1. Improved date handling;
2. Improved 'Received' header handling;
3. Added 'Mime-Version' field;
4. Added 'Content-Length' field;
5. Fixed bug when there is comma between quotes;
6. Several compatibility improvements;
7. Several redundancies removed;
8. Added 'Embedded' option for attachments;
9. Improved mail bulding structure and algorithm;
10. Added 'FindParts' to identify texts and attachments of foreing messages;
11. Removed 'GetAttachList' (now obsolete);
12. Added 'Normalize' to reformat foreing messages on Mail2000 standards;
13. Changed 'SetTextPlain' and 'SetTextHTML' to work with String type;
14. Added 'LoadFromStream' and 'SaveToStream';
15. Added 'MessageSource' read/write String property;
16. Added 'GetUIDL' method to POP component;
17. Added 'DetachFile' method;
18. Added 'Abort' method to POP and SMTP components;
19. Better handling of recipient fields (TMailRecipients);
20. Added 'AttachString' method;
21. Added 'AddHop' method;
22. Added 'SendMessageTo' method to SMTP component;
23. Added 'SendStringTo' method to SMTP component;
24. POP and SMTP components hard-tested;
25. POP and SMTP doesn't require MailMessage to work anymore;
26. Removed proxy support (but still working with ordinary proxy redirection);
27. Fixed one dot line causing SMTP to truncate the message;
28. Fixed long lines on header;
29. Added 'TextEncoding' published property;
30. SendMessage will abort on first recipient rejected;
31. Treatment of dates without seconds.
Author data
-----------
Marcello Roberto Tavares Pereira
http://mpanda.8m.com
ICQ 5831833
Sorocaba/SP - BRAZIL
Spoken languages: Portuguese, English, Spanish
Discussion Group
----------------
Please join TMail2000 group, exchange information about mailing
application development with another power programmers, and receive
suggestions, advices, bugfixes and updates about this component.
http://groups.yahoo.com/group/tmail2000
This site stores all previous messages, you can find valuable
information about this component there. If you have a question,
please search this site before asking me, I will not post the
same answer twice.
*)
(*
clq:
以下为我修改后的注释:
代码是我多年前在 mail2000 在进行修改的,很惭愧代码改得很乱.以后有时间再整理吧,最
近因为要写电子邮件文章又进行了一些改进,改得这么烂的实在不想放上来,但又害怕弄丢了,
所以大家将就用吧.以下是一些修改记录(2018 年后的,之前的没有了).
1.
2018.02.05
原来对 mime 的理解不足,解码 utf8 时没有考虑编码的情况,现在修正为已经 base64 解码
后的再转换字符集
self.FDecoded.SaveToStream(f_buf1); //clq 2018.02.05 应该转码解码后的字符串流
2.
修改了函数 TMailPart.GetLabelValue
2018-2-5 clq 从这一行开始后面以空格或者 tab 开头的其实都算是它的内容,因为是折行后的
*)
unit Mail2000;
{Please don't remove the following line}
{$BOOLEVAL OFF}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
CVCode,//big5,
DateUtils,
IdCoderQuotedPrintable,
StrUtils,
WinSock, ScktComp, Math, Registry, ExtCtrls;
type
TMailPartList = class;
TMailMessage2000 = class;
TSocketTalk = class;
TMessageSize = array of Integer;
TSessionState = (stNone, stConnect, stUser, stPass, stStat, stList, stRetr, stDele, stUIDL, stHelo, stMail, stRcpt, stData, stSendData, stQuit);
TTalkError = (teGeneral, teSend, teReceive, teConnect, teDisconnect, teAccept, teTimeout, teNoError);
TEncodingType = (etBase64, etQuotedPrintable, etNoEncoding, et7Bit);
TProgressEvent = procedure(Sender: TObject; Total, Current: Integer) of object;
TEndOfDataEvent = procedure(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean) of object;
TSocketTalkErrorEvent = procedure(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError) of object;
TReceiveDataEvent = procedure(Sender: TObject; Sessionstate: TSessionState; Data: String; var ServerResult: Boolean) of object;
TReceivedField = (reFrom, reBy, reFor, reDate, reNone);
TReceived = record
From: String;
By: String;
Address: String;
Date: TDateTime;
end;
{ TMailPart - A recursive class to handle parts, subparts, and the mail by itself }
TMailPart = class(TComponent)
private
FHeader: TStringList {TMailText};
FBody: TMemoryStream;
// 2019/7/24 21:20:09 //clq 这个应该指的是解码后的结果
FDecoded: TMemoryStream;
FParentBoundary: String;
FOwnerMessage: TMailMessage2000;
FSubPartList: TMailPartList;
FOwnerPart: TMailPart;
FAttachedMessage: TMailMessage2000;
FIsDecoded: Boolean;
FEmbedded: Boolean;
FDecoded_Bin: TMemoryStream;
function GetAttachInfo: String;
function GetFileName: String;
function GetBoundary: String;
function GetSource: String;
procedure Fill(Data: PChar; HasHeader: Boolean);
procedure SetSource(const Text: String);
function GetHeader(const cLabel: String): String;
public
charset:string; // 2019/7/24 21:30:08//clq add 这个部分的字符集，例如 utf-8,gb2312 //已经转化为全小写
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetLabelValue(const cLabel: String): String; // Get the value of a label. e.g. Label: value
function GetLabelParamValue(const cLabel, Param: String): String; // Get the value of a label parameter. e.g. Label: xxx; param=value
function LabelExists(const cLabel: String): Boolean; // Determine if a label exists
function LabelParamExists(const cLabel, Param: String): Boolean; // Determine if a label parameter exists
function Decode: Boolean; // Decode Body stream into Decoded stream and result true if successful
procedure Encode(const ET: TEncodingType);
procedure EncodeText; // Encode Decoded stream into Body stream using quoted-printable
procedure EncodeBinary; // Encode Decoded stream into Body stream using Base64
//clq 用这两个函数进行标志扩展是没问题的
procedure SetLabelValue(const cLabel, cValue: String); // Set the value of a label
procedure SetLabelParamValue(const cLabel, cParam, cValue: String); // Set the value of a label parameter
procedure Remove; // Delete this mailpart from message
procedure LoadFromFile(FileName: String); // Load the data from a file
procedure SaveToFile(FileName: String); // Save the data to a file
procedure LoadFromStream(Stream: TStream); // Load the data from a stream
procedure SaveToStream(Stream: TStream); // Save the data to a stream
property PartSource: String read GetSource write SetSource;
property Header: TStringList read FHeader; // The header text
property Body: TMemoryStream read FBody; // The original body
// 2019/7/24 21:49:31//clq 这个是解码 base64 的字符集后的字符串，所以要加一个未解码字符集的
property Decoded: TMemoryStream read FDecoded; // Stream with the body decoded
property Decoded_Bin: TMemoryStream read FDecoded_Bin;
property SubPartList: TMailPartList read FSubPartList; // List of subparts of this mail part
property FileName: String read GetFileName; // Name of file when this mail part is an attached file
property AttachInfo: String read GetAttachInfo; // E.g. application/octet-stream
property OwnerMessage: TMailMessage2000 read FOwnerMessage; // Main message that owns this mail part
property OwnerPart: TMailPart read FOwnerPart; // Father part of this part (can be the main message too)
property IsDecoded: Boolean read FIsDecoded; // If this part is decoded
property Embedded: Boolean read FEmbedded write FEmbedded; // E.g. if is a picture inside HTML text
end;
{ TMailPartList - Just a collection of TMailPart's }
TMailPartList = class(TList)
private
function Get(const Index: Integer): TMailPart;
public
destructor Destroy; override;
property Items[const Index: Integer]: TMailPart read Get; default;
end;
{ TMailRecipients - Handling of recipient fields }
TMailRecipients = class(TObject)
private
FMessage: TMailMessage2000;
FField: String;
FNames: TStringList;
FAddresses: TStringList;
FCheck: Integer;
function GetName(const Index: Integer): String;
function GetAddress(const Index: Integer): String;
function GetCount: Integer;
procedure SetName(const Index: Integer; const Name: String);
procedure SetAddress(const Index: Integer; const Address: String);
function FindName(const Name: String): Integer;
function FindAddress(const Address: String): Integer;
function GetAllNames: String;
function GetAllAddresses: String;
procedure HeaderToStrings;
procedure StringsToHeader;
public
constructor Create(MailMessage: TMailMessage2000; Field: String); //override;
destructor Destroy; override;
procedure Add(const Name, Address: String);
procedure Replace(const Index: Integer; const Name, Address: String);
procedure Delete(const Index: Integer);
procedure SetAll(const Names, Addresses: String);
procedure AddNamesTo(const Str: TStrings);
procedure AddAddressesTo(const Str: TStrings);
procedure Clear;
property Count: Integer read GetCount;
property Name[const Index: Integer]: String read GetName write SetName;
property Address[const Index: Integer]: String read GetAddress write SetAddress;
property ByName[const Name: String]: Integer read FindName;
property ByAddress[const Name: String]: Integer read FindAddress;
property AllNames: String read GetAllNames;
property AllAddresses: String read GetAllAddresses;
end;
{ TMailMessage2000 - A descendant of TMailPart with some tools to handle the mail }
TMailMessage2000 = class(TMailPart)
private
FAttachList: TMailPartList;
FTextPlain: TStringList;
FTextHTML: TStringList;
FTextPlainPart: TMailPart;
FTextHTMLPart: TMailPart;
FMixedPart: TMailPart;
FRelatedPart: TMailPart;
FAlternativePart: TMailPart;
FCharset: String;
FOnProgress: TProgressEvent;
FNameCount: Integer;
FToList: TMailRecipients;
FCcList: TMailRecipients;
FBccList: TMailRecipients;
FTextEncoding: TEncodingType;
FNeedRebuild: Boolean;
FNeedNormalize: Boolean;
FNeedFindParts: Boolean;
function GetDestName(Field: String; const Index: Integer): String;
function GetDestAddress(Field: String; const Index: Integer): String;
function GetReceivedCount: Integer;
function GetReceived(const Index: Integer): TReceived;
function GetAttach(const FileName: String): TMailPart;
function GetFromName: String;
function GetFromAddress: String;
function GetReplyToName: String;
function GetReplyToAddress: String;
function GetSubject: String;
function GetDate: TDateTime;
function GetMessageId: String;
procedure PutText(Text: String; Part: TMailPart; Content: String);
procedure SetSubject(const Subject: String);
procedure SetDate(const Date: TDateTime);
procedure SetMessageId(const MessageId: String);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SetFrom(const Name, Address: String); // Create/modify the From: field
procedure SetReplyTo(const Name, Address: String); // Create/modify the Reply-To: field
procedure FindParts; // Search for the attachments and texts
procedure Normalize; // Reconstruct message on Mail2000 standards (multipart/mixed)
procedure RebuildBody; // Build the raw mail body according to mailparts
procedure Reset; // Clear all stored data in the object
procedure SetTextPlain(const Text: String); // Create/modify a mailpart for text/plain (doesn't rebuild body)
procedure SetTextHTML(const Text: String); // Create/modify a mailpart for text/html (doesn't rebuild body)
procedure RemoveTextPlain; // Remove the text/plain mailpart (doesn't rebuild body)
procedure RemoveTextHTML; // Remove the text/html mailpart (doesn't rebuild body)
procedure AttachFile(const FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
// Create a mailpart and encode a file on it (doesn't rebuild body)
procedure AttachString(const Text, FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
// Create a mailpart and encode a string on it (doesn't rebuild body)
procedure AttachStream(const AStream: TStream; const FileName: String; const ContentType: String = ''; const EncodingType: TEncodingType = etBase64; const IsEmbedded: Boolean = False);
// Create a mailpart and encode a stream on it (doesn't rebuild body)
procedure DetachFile(const FileName: String);
// Remove attached file from message by name
procedure DetachFileIndex(const Index: Integer);
// Remove attached file from message by index of AttachList
procedure AddHop(const From, By, Aplic, Address: String); // Add a 'Received:' in message header
property Received[const Index: Integer]: TReceived read GetReceived; // Retrieve the n-th 'Received' header
property ReceivedCount: Integer read GetReceivedCount; // Count the instances of 'Received' fields (hops)
property AttachByName[const FileName: String]: TMailPart read GetAttach; // Returns the MailPart of an attachment by filename
property ToList: TMailRecipients read FToList; // Handling of To: recipients
property CcList: TMailRecipients read FCcList; // Handling of Cc: recipients
property BccList: TMailRecipients read FBccList; // Handling of Bcc: recipients
property MessageSource: String read GetSource write SetSource;
property FromName: String read GetFromName; // Retrieve the From: name
property FromAddress: String read GetFromAddress; // Retrieve the From: address
property ReplyToName: String read GetReplyToName; // Retrieve the Reply-To: name
property ReplyToAddress: String read GetReplyToAddress; // Retrieve the Reply-To: address
property Subject: String read GetSubject write SetSubject; // Retrieve or set the Subject: string
property Date: TDateTime read GetDate write SetDate; // Retrieve or set the Date: in TDateTime format
property MessageId: String read GetMessageId write SetMessageId; // Retrieve or set the Message-Id:
property AttachList: TMailPartList read FAttachList; // A list of all attached files
property TextPlain: TStringList read FTextPlain; // A StringList with the text/plain from message
property TextHTML: TStringList read FTextHTML; // A StringList with the text/html from message
property TextPlainPart: TMailPart read FTextPlainPart; // The text/plain part
property TextHTMLPart: TMailPart read FTextHTMLPart; // The text/html part
property NeedRebuild: Boolean read FNeedRebuild; // True if RebuildBody is needed
property NeedNormalize: Boolean read FNeedNormalize; // True if message needs to be normalized
property NeedFindParts: Boolean read FNeedFindParts; // True if message has parts to be searched for
published
//property Charset: String read FCharSet write FCharset default 'sss';//'iso-8859-1'; // Charset to build headers and text
//property TextEncoding: TEncodingType read FTextEncoding write FTextEncoding default etQuotedPrintable; // How text will be encoded
property OnProgress: TProgressEvent read FOnProgress write FOnProgress; // Occurs when storing message in memory
end;
{ TSocketTalk }
TSocketTalk = class(TComponent)
private
FTimeOut: Integer;
FExpectedEnd: String;
FLastResponse: String;
FDataSize: Integer;
FPacketSize: Integer;
FTalkError: TTalkError;
FSessionState: TSessionState;
FClientSocket: TClientSocket;
FWaitingServer: Boolean;
FTimer: TTimer;
FServerResult: Boolean;
FOnProgress: TProgressEvent;
FOnEndOfData: TEndOfDataEvent;
FOnSocketTalkError: TSocketTalkErrorEvent;
FOnReceiveData: TReceiveDataEvent;
FOnDisconnect: TNotifyEvent;
procedure SocketRead(Sender: TObject; Socket: TCustomWinSocket);
procedure SocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure SocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
procedure Timer(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Talk(Buffer, EndStr: String; SessionState: TSessionState);
procedure Cancel;
procedure ForceState(SessionState: TSessionState);
procedure WaitServer;
property LastResponse: String read FLastResponse;
property DataSize: Integer read FDataSize write FDataSize;
property PacketSize: Integer read FPacketSize write FPacketSize;
property TimeOut: Integer read FTimeOut write FTimeOut;
property TalkError: TTalkError read FTalkError;
property ClientSocket: TClientSocket read FClientSocket;
property ServerResult: Boolean read FServerResult;
property OnEndOfData: TEndOfDataEvent read FOnEndOfData write FOnEndOfData;
property OnSocketTalkError: TSocketTalkErrorEvent read FOnSocketTalkError write FOnSocketTalkError;
property OnReceiveData: TReceiveDataEvent read FOnReceiveData write FOnReceiveData;
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
end;
{ TPOP2000 }
TPOP2000 = class(TComponent)
private
FMailMessage: TMailMessage2000;
FSessionMessageCount: Integer;
FSessionMessageSize: TMessageSize;
FSessionConnected: Boolean;
FSessionLogged: Boolean;
FLastMessage: String;
FSocketTalk: TSocketTalk;
FUserName: String;
FPassword: String;
FPort: Integer;
FHost: String;
FDeleteOnRetrieve: Boolean;
procedure EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
procedure SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
procedure ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
procedure SocketDisconnect(Sender: TObject);
function GetTimeOut: Integer;
procedure SetTimeOut(Value: Integer);
function GetProgress: TProgressEvent;
procedure SetProgress(Value: TProgressEvent);
function GetLastResponse: String;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Connect: Boolean; // Connect to mail server
function Login: Boolean; // Autenticate to mail server
function Quit: Boolean; // Logout and disconnect
procedure Abort; // Force disconnect
function RetrieveMessage(Number: Integer): Boolean; // Retrieve mail number # and put in MailMessage
function RetrieveHeader(Number: Integer; Lines: Integer = 0): Boolean; // Retrieve header and put in MailMessage
function DeleteMessage(Number: Integer): Boolean; // Delete mail number #
function GetUIDL(Number: Integer): String; // Get UIDL from mail number #
property SessionMessageCount: Integer read FSessionMessageCount; // Number of messages found on server
property SessionMessageSize: TMessageSize read FSessionMessageSize; // Dynamic array with size of the messages
property SessionConnected: Boolean read FSessionConnected; // True if conencted to server
property SessionLogged: Boolean read FSessionLogged; // True if autenticated on server
property LastMessage: String read FLastMessage; // Last integral message text
property LastResponse: String read GetLastResponse; // Last string received from server
published
property UserName: String read FUserName write FUserName; // User name to login on server
property Password: String read FPassword write FPassword; // Password
property Port: Integer read FPort write FPort; // Port (usualy 110)
property Host: String read FHost write FHost; // Host address
property MailMessage: TMailMessage2000 read FMailMessage write FMailMessage; // Message retrieved
property TimeOut: Integer read GetTimeOut write SetTimeOut; // Max time to wait for server reply in seconds
property OnProgress: TProgressEvent read GetProgress write SetProgress; // Occurs when receiving data from server
property DeleteOnRetrieve: Boolean read FDeleteOnRetrieve write FDeleteOnRetrieve; // If message will be deleted after successful retrieve
end;
{ TSMTP2000 }
TSMTP2000 = class(TComponent)
private
FMailMessage: TMailMessage2000;
FSessionConnected: Boolean;
FSocketTalk: TSocketTalk;
FPacketSize: Integer;
FPort: Integer;
FHost: String;
procedure EndOfData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
procedure SocketTalkError(Sender: TObject; SessionState: TSessionState; TalkError: TTalkError);
procedure ReceiveData(Sender: TObject; SessionState: TSessionState; Data: String; var ServerResult: Boolean);
procedure SocketDisconnect(Sender: TObject);
function GetTimeOut: Integer;
procedure SetTimeOut(Value: Integer);
function GetProgress: TProgressEvent;
procedure SetProgress(Value: TProgressEvent);
function GetLastResponse: String;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Connect: Boolean; // Connect to mail server
function Quit: Boolean; // Disconnect
procedure Abort; // Force disconnect
function SendMessage: Boolean; // Send MailMessage to server
function SendMessageTo(const From, Dests: String): Boolean; // Send MailMessage to specified recipients
function SendStringTo(const Msg, From, Dests: String): Boolean; // Send string to specified recipients
property SessionConnected: Boolean read FSessionConnected; // True if conencted to server
property LastResponse: String read GetLastResponse; // Last string received from server
published
property Port: Integer read FPort write FPort; // Port (usualy 25)
property Host: String read FHost write FHost; // Host address
property TimeOut: Integer read GetTimeOut write SetTimeOut; // Max time to wait for a response in seconds
property MailMessage: TMailMessage2000 read FMailMessage write FMailMessage; // Message to send
property PacketSize: Integer read FPacketSize write FPacketSize; // Size of packets to send to server
property OnProgress: TProgressEvent read GetProgress write SetProgress; // Occurs when sending data to server
end;
procedure Register;
{ Very useful functions ====================================================== }
function DecodeLine7Bit(Texto: String): String; forward;
function DecodeLine7Bit_m(s: String): String;
function EncodeLine7Bit(Texto, Charset: String): String; forward;
function DecodeQuotedPrintable(const Texto: String): String; forward;
function EncodeQuotedPrintable(Texto: String; HeaderLine: Boolean): String; forward;
function DecodeUUCODE(Encoded: PChar; Decoded: TMemoryStream): Boolean; forward;
function DecodeLineUUCODE(const Buffer: String; Decoded: PChar): Integer; forward;
function DecodeLineBASE64(const Buffer: String; Decoded: PChar): Integer; forward;
function EncodeBASE64(Encoded: TMemoryStream {TMailText}; Decoded: TMemoryStream): Integer; forward;
function NormalizeLabel(Texto: String): String; forward;
function LabelValue(cLabel: String): String; forward;
function WriteLabelValue(cLabel, Value: String): String; forward;
function LabelParamValue(cLabel, cParam: String): String; forward;
function WriteLabelParamValue(cLabel, cParam, Value: String): String; forward;
function GetTimeZoneBias: Double; forward;
function PadL(const Str: String; const Tam: Integer; const PadStr: String): String; forward;
function GetMimeType(const FileName: String): String; forward;
function GetMimeExtension(const MimeType: String): String; forward;
function GenerateBoundary: String; forward;
function SearchStringList(Lista: TStringList; const Chave: String; const Occorrence: Integer = 0): Integer; forward;
procedure DataLine(var Data, Line: String; var nPos: Integer); forward;
procedure DataLinePChar(const Data: PChar; const TotalLength: Integer; var LinePos, LineLen: Integer; var Line: PChar; var DataEnd: Boolean); forward;
function IsIPAddress(const SS: String): Boolean; forward;
function TrimSpace(const S: string): string; forward;
function TrimLeftSpace(const S: string): string; forward;
function TrimRightSpace(const S: string): string; forward;
function MailDateToDelphiDate(const DateStr: String): TDateTime; forward;
function DelphiDateToMailDate(const Date: TDateTime): String; forward;
function ValidFileName(FileName: String): String; forward;
function WrapHeader(Text: String): String; forward;
procedure save_to_file1(msg1:TMailMessage2000;fn1:string);
const
//clq 扩展的标志//例子为 X-Clq: yes; half="yes"; filename="1.bmp; v_filename="200307..."; index=0
//函数调用为
{
Part.SetLabelValue(_CLQ_, _CLQ_YES);
Part.SetLabelParamValue(_CLQ_, _CLQ_HALF, '"'+_CLQ_YES+'"');
//下面是文件名,一般还要用EncodeLine7Bit处理,可放入多个文件名
Part.SetLabelParamValue(_CLQ_, _CLQ_HALF_FILENAME, '"'+"1.bmp"+'"');
}
_CLQ_ = 'X-Clq';
_CLQ_YES = 'yes';
_CLQ_HALF = 'half'; //大文件分块模式
_CLQ_HALF_FILENAME = 'filename'; //大文件分块模式 文件名
_CLQ_HALF_VFILENAME = 'v_filename';
_CLQ_HALF_INDEX = 'index';
_CLQ_HALF_COUNT = 'count';
_CLQ_MMAIL = 'mmail'; //存在此Param的话就是群发
_CLQ_MMAIL_ADDRS = 'X-Clq-mmail_addrs'; //群发邮件的地址表
implementation
uses
clq_pub_pas1,
clq_work_pub_pas1,
Functions,
utf8_decode;
const
_C_T = 'Content-Type';
_C_D = 'Content-Disposition';
_C_TE = 'Content-Transfer-Encoding';
_C_ID = 'Content-ID';
_C_L = 'Content-Length';
_CONT = 'Content-';
_FFR = 'From';
_FRT = 'Reply-To';
_M_V = 'Mime-Version';
_M_ID = 'Message-ID';
_X_M = 'X-Mailer';
const
_TXT = 'text/';
_T_P = 'text/plain';
_T_H = 'text/html';
_MP = 'multipart/';
_M_M = 'multipart/mixed';
_M_A = 'multipart/alternative';
_M_R = 'multipart/related';
_M_RP = 'multipart/report';
_A_OS = 'application/octet-stream';
_BDRY = 'boundary';
_ATCH = 'attachment';
_INLN = 'inline';
const
_MIME_Msg = 'This is a multipart message in mime format.'#13#10;
// _XMailer = 'Mail2000 1.9 beta http://groups.yahoo.com/group/tmail2000';
_XMailer = 'Mail2000 [clq modify 2018 https://github.com/clqsrc/delphi_lost] 1.9 beta http://groups.yahoo.com/group/tmail2000';
_TXTFN = 'textpart.txt';
_HTMLFN = 'textpart.htm';
_CHARSET = 'GB2312'; //英文版本应该是'iso-8859-1';//以后可以改用screen.font.Charset来算出来
_DATAEND1 = #13#10'.'#13#10;
_DATAEND2 = #13#10'..'#13#10;
_LINELEN = 72;
procedure Register;
begin
RegisterComponents('clq', [TPOP2000, TSMTP2000, TMailMessage2000]);
end;
//clq 这里应该是解码标题等的东东
//对应函数为 EncodeLine7Bit
// Decode an encoded field e.g. =?iso-8859-1?x?xxxxxx=?=
{
clq:对于日文的系统中 X-Mailer: Microsoft Outlook Express 6.00.2462.0000的情况下可能有
Subject: =?utf-8?B?5YWz5LqO5LuK5aSp55qE5bel5L2c?=
这样是字符串无法正确显示
所以要加以修正
}
function DecodeLine7Bit_old(Texto: String): String;
var
Buffer: PChar;
Encoding: Char;
Size: Integer;
nPos0: Integer;
nPos1: Integer;
nPos2: Integer;
nPos3: Integer;
Found: Boolean;
//clq
old1:string;
clq_get1:boolean;
//clq_end;
begin
//clq
old1:=Texto;
clq_get1:=false;
//clq_end;
Result := TrimSpace(Texto);
repeat
nPos0 := Pos('=?', Result);
Found := False;
if nPos0 > 0 then
begin
nPos1 := Pos('?', Copy(Result, nPos0+2, Length(Result)))+nPos0+1;
nPos2 := Pos('?=', Copy(Result, nPos1+1, Length(Result)))+nPos1;
nPos3 := Pos('?', Copy(Result, nPos2+1, Length(Result)))+nPos2;
if nPos3 > nPos2 then
begin
if Length(Result) > nPos3 then
begin
if Result[nPos3+1] = '=' then
begin
nPos2 := nPos3;
end;
end;
end;
if (nPos1 > nPos0) and (nPos2 > nPos1) then
begin
Texto := Copy(Result, nPos1+1, nPos2-nPos1-1);
if (Length(Texto) >= 2) and (Texto[2] = '?') and (UpCase(Texto[1]) in ['B', 'Q', 'U']) then
begin
Encoding := UpCase(Texto[1]);
end
else
begin
Encoding := 'Q';
end;
Texto := Copy(Texto, 3, Length(Texto)-2);
case Encoding of
'B':
begin
GetMem(Buffer, Length(Texto));
Size := DecodeLineBASE64(Texto, Buffer);
Buffer[Size] := #0;
Texto := String(Buffer);
end;
'Q':
begin
while Pos('_', Texto) > 0 do
Texto[Pos('_', Texto)] := #32;
//当字符串中含有?号和=号等并同时含有中文时,这里的作为输入的Texto是错误的,应当另外取给它