source: tags/1.0.0/UContact.pas

Last change on this file was 21, checked in by chronos, 5 years ago
  • Fixed: Build under Lazarus 2.0.
  • Modified: Used .lrj files instead of .lrt files.
  • Removed: TemplateGenerics package.
File size: 18.5 KB
Line 
1unit UContact;
2
3{$mode delphi}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, Contnrs, Dialogs, UDataFile, LazUTF8, base64;
9
10type
11 TContactsFile = class;
12
13 TStringEvent = procedure (Text: string) of object;
14
15 TDataType = (dtString, dtInteger, dtDate, dtDateTime, dtImage);
16
17 TContactFieldIndex = (cfFirstName, cfMiddleName, cfLastName, cfTitleBefore,
18 cfTitleAfter, cfFullName, cfTelPrefCell,
19 cfTelCell, cfTelHome, cfTelHome2, cfTelWork, cfTelVoip,
20 cfTelPrefWorkVoice, cfTelPrefHomeVoice, cfTelHomeVoice, cfTelWorkVoice,
21 cfEmailHome, cfEmailInternet, cfNickName, cfNote, cfRole, cfTitle,
22 cfCategories, cfOrganization, cfAdrHome, cfHomeAddressStreet,
23 cfHomeAddressCity, cfHomeAddressCountry, cfXTimesContacted,
24 cfXLastTimeContacted, cfPhoto, cfXJabber);
25
26 TContactField = class
27 Name: string;
28 Index: TContactFieldIndex;
29 DataType: TDataType;
30 end;
31
32 { TContactFields }
33
34 TContactFields = class(TObjectList)
35 function AddNew(Name: string; Index: TContactFieldIndex; DataType:
36 TDataType): TContactField;
37 procedure LoadToStrings(AItems: TStrings);
38 end;
39
40 { TContact }
41
42 TContact = class
43 private
44 function GetField(Index: TContactFieldIndex): string;
45 procedure SetField(Index: TContactFieldIndex; AValue: string);
46 public
47 Parent: TContactsFile;
48 Version: string;
49 FirstName: string;
50 MiddleName: string;
51 LastName: string;
52 TitleBefore: string;
53 TitleAfter: string;
54 FullName: string;
55 TelPrefCell: string;
56 TelCell: string;
57 TelHome: string;
58 TelHome2: string;
59 TelWork: string;
60 TelVoip: string;
61 TelPrefWorkVoice: string;
62 TelPrefHomeVoice: string;
63 TelHomeVoice: string;
64 TelWorkVoice: string;
65 EmailHome: string;
66 EmailInternet: string;
67 NickName: string;
68 Note: string;
69 Role: string;
70 Title: string;
71 Categories: string;
72 Organization: string;
73 AdrHome: string;
74 HomeAddressStreet: string;
75 HomeAddressCity: string;
76 HomeAddressCountry: string;
77 XTimesContacted: string;
78 XLastTimeContacted: string;
79 Photo: string;
80 XJabber: string;
81 procedure Assign(Source: TContact);
82 function UpdateFrom(Source: TContact): Boolean;
83 property Fields[Index: TContactFieldIndex]: string read GetField write SetField;
84 end;
85
86 { TContacts }
87
88 TContacts = class(TObjectList)
89 ContactsFile: TContactsFile;
90 function AddNew: TContact;
91 function Search(FullName: string): TContact;
92 function ToString: ansistring; override;
93 end;
94
95 { TContactsFile }
96
97 TContactsFile = class(TDataFile)
98 private
99 FOnError: TStringEvent;
100 function GetNext(var Text: string; Separator: string): string;
101 procedure InitFields;
102 public
103 Fields: TContactFields;
104 Contacts: TContacts;
105 function GetFileName: string; override;
106 function GetFileExt: string; override;
107 function GetFileFilter: string; override;
108 procedure SaveToFile(FileName: string); override;
109 procedure LoadFromFile(FileName: string); override;
110 constructor Create; override;
111 destructor Destroy; override;
112 property OnError: TStringEvent read FOnError write FOnError;
113 end;
114
115
116implementation
117
118resourcestring
119 SVCardFile = 'vCard file';
120 SUnsupportedContactFieldsIndex = 'Unsupported contact field index';
121
122{ TContacts }
123
124function TContacts.AddNew: TContact;
125begin
126 Result := TContact.Create;
127 Result.Parent := ContactsFile;
128 Add(Result);
129end;
130
131function TContacts.Search(FullName: string): TContact;
132var
133 Contact: TContact;
134begin
135 Result := nil;
136 for Contact in Self do
137 if Contact.FullName = FullName then begin
138 Result := Contact;
139 Break;
140 end;
141end;
142
143function TContacts.ToString: ansistring;
144var
145 I: Integer;
146begin
147 Result := '';
148 for I := 0 to Count - 1 do begin
149 if I > 0 then Result := Result + ', ';
150 Result := Result + TContact(Items[I]).FullName;
151 end;
152end;
153
154{ TContactFields }
155
156function TContactFields.AddNew(Name: string; Index: TContactFieldIndex;
157 DataType: TDataType): TContactField;
158begin
159 Result := TContactField.Create;
160 Result.Name := Name;
161 Result.Index := Index;
162 Result.DataType := DataType;
163 Add(Result);
164end;
165
166procedure TContactFields.LoadToStrings(AItems: TStrings);
167var
168 I: Integer;
169begin
170 while AItems.Count < Count do AItems.Add('');
171 while AItems.Count > Count do AItems.Delete(AItems.Count - 1);
172 for I := 0 to Count - 1 do
173 AItems[I] := TContactField(Items[I]).Name;
174end;
175
176{ TContact }
177
178function TContact.GetField(Index: TContactFieldIndex): string;
179begin
180 case Index of
181 cfFirstName: Result := FirstName;
182 cfMiddleName: Result := MiddleName;
183 cfLastName: Result := LastName;
184 cfTitleBefore: Result := TitleBefore;
185 cfTitleAfter: Result := TitleAfter;
186 cfFullName: Result := FullName;
187 cfTelPrefCell: Result := TelPrefCell;
188 cfTelCell: Result := TelCell;
189 cfTelHome: Result := TelHome;
190 cfTelHome2: Result := TelHome2;
191 cfTelWork: Result := TelWork;
192 cfTelVoip: Result := TelVoip;
193 cfTelPrefWorkVoice: Result := TelPrefWorkVoice;
194 cfTelPrefHomeVoice: Result := TelPrefHomeVoice;
195 cfTelHomeVoice: Result := TelHomeVoice;
196 cfTelWorkVoice: Result := TelWorkVoice;
197 cfEmailHome: Result := EmailHome;
198 cfEmailInternet: Result := EmailInternet;
199 cfNickName: Result := NickName;
200 cfNote: Result := Note;
201 cfRole: Result := Role;
202 cfTitle: Result := Title;
203 cfCategories: Result := Categories;
204 cfOrganization: Result := Organization;
205 cfAdrHome: Result := AdrHome;
206 cfHomeAddressStreet: Result := HomeAddressStreet;
207 cfHomeAddressCity: Result := HomeAddressCity;
208 cfHomeAddressCountry: Result := HomeAddressCountry;
209 cfXTimesContacted: Result := XTimesContacted;
210 cfXLastTimeContacted: Result := XLastTimeContacted;
211 cfPhoto: Result := Photo;
212 cfXJabber: Result := XJabber;
213 else raise Exception.Create(SUnsupportedContactFieldsIndex);
214 end;
215end;
216
217procedure TContact.SetField(Index: TContactFieldIndex; AValue: string);
218begin
219 case Index of
220 cfFirstName: FirstName := AValue;
221 cfMiddleName: MiddleName := AValue;
222 cfLastName: LastName := AValue;
223 cfTitleBefore: TitleBefore := AValue;
224 cfTitleAfter: TitleAfter := AValue;
225 cfFullName: FullName := AValue;
226 cfTelPrefCell: TelPrefCell := AValue;
227 cfTelCell: TelCell := AValue;
228 cfTelHome: TelHome := AValue;
229 cfTelHome2: TelHome2 := AValue;
230 cfTelWork: TelWork := AValue;
231 cfTelVoip: TelVoip := AValue;
232 cfTelPrefWorkVoice: TelPrefWorkVoice := AValue;
233 cfTelPrefHomeVoice: TelPrefHomeVoice := AValue;
234 cfTelHomeVoice: TelHomeVoice := AValue;
235 cfTelWorkVoice: TelWorkVoice := AValue;
236 cfEmailHome: EmailHome := AValue;
237 cfEmailInternet: EmailInternet := AValue;
238 cfNickName: NickName := AValue;
239 cfNote: Note := AValue;
240 cfRole: Role := AValue;
241 cfTitle: Title := AValue;
242 cfCategories: Categories := AValue;
243 cfOrganization: Organization := AValue;
244 cfAdrHome: AdrHome := AValue;
245 cfHomeAddressStreet: HomeAddressStreet := AValue;
246 cfHomeAddressCity: HomeAddressCity := AValue;
247 cfHomeAddressCountry: HomeAddressCountry := AValue;
248 cfXTimesContacted: XTimesContacted := AValue;
249 cfXLastTimeContacted: XLastTimeContacted := AValue;
250 cfPhoto: Photo := AValue;
251 cfXJabber: XJabber := AValue;
252 else raise Exception.Create(SUnsupportedContactFieldsIndex);
253 end;
254end;
255
256procedure TContact.Assign(Source: TContact);
257begin
258 Version := Source.Version;
259 FirstName := Source.FirstName;
260 MiddleName := Source.MiddleName;
261 LastName := Source.LastName;
262 TitleBefore := Source.TitleBefore;
263 TitleAfter := Source.TitleAfter;
264 FullName := Source.FullName;
265 TelPrefCell := Source.TelPrefCell;
266 TelCell := Source.TelCell;
267 TelHome := Source.TelHome;
268 TelHome2 := Source.TelHome2;
269 TelWork := Source.TelWork;
270 TelVoip := Source.TelVoip;
271 TelPrefWorkVoice := Source.TelPrefWorkVoice;
272 TelPrefHomeVoice := Source.TelPrefHomeVoice;
273 TelHomeVoice := Source.TelHomeVoice;
274 TelWorkVoice := Source.TelWorkVoice;
275 EmailHome := Source.EmailHome;
276 EmailInternet := Source.EmailInternet;
277 NickName := Source.NickName;
278 Note := Source.Note;
279 Role := Source.Role;
280 Title := Source.Title;
281 Categories := Source.Categories;
282 Organization := Source.Organization;
283 AdrHome := Source.AdrHome;
284 HomeAddressStreet := Source.HomeAddressStreet;
285 HomeAddressCity := Source.HomeAddressCity;
286 HomeAddressCountry := Source.HomeAddressCountry;
287 XTimesContacted := Source.XTimesContacted;
288 XLastTimeContacted := Source.XLastTimeContacted;
289 Photo := Source.Photo;
290 XJabber := Source.XJabber;
291end;
292
293function TContact.UpdateFrom(Source: TContact): Boolean;
294var
295 I: Integer;
296begin
297 Result := False;
298 for I := 0 to Parent.Fields.Count - 1 do begin
299 if (Source.Fields[TContactField(Parent.Fields[I]).Index] <> '') and
300 (Source.Fields[TContactField(Parent.Fields[I]).Index] <>
301 Fields[TContactField(Parent.Fields[I]).Index]) then begin
302 Result := True;
303 Fields[TContactField(Parent.Fields[I]).Index] := Source.Fields[TContactField(Parent.Fields[I]).Index];
304 end;
305 end;
306end;
307
308{ TContactsFile }
309
310function TContactsFile.GetNext(var Text: string; Separator: string): string;
311begin
312 if Pos(Separator, Text) > 0 then begin
313 Result := Copy(Text, 1, Pos(Separator, Text) - 1);
314 Delete(Text, 1, Length(Result) + Length(Separator));
315 end else begin
316 Result := Text;
317 Text := '';
318 end;
319end;
320
321procedure TContactsFile.InitFields;
322begin
323 with Fields do begin
324 AddNew('First Name', cfFirstName, dtString);
325 AddNew('Middle Name', cfMiddleName, dtString);
326 AddNew('Last Name', cfLastName, dtString);
327 AddNew('Title Before', cfTitleBefore, dtString);
328 AddNew('Title After', cfTitleAfter, dtString);
329 AddNew('Full Name', cfFullName, dtString);
330 AddNew('Preferred cell phone', cfTelPrefCell, dtString);
331 AddNew('Cell phone', cfTelCell, dtString);
332 AddNew('Home phone', cfTelHome, dtString);
333 AddNew('Home phone 2', cfTelHome2, dtString);
334 AddNew('Home work', cfTelWork, dtString);
335 AddNew('Tel Voip', cfTelVoip, dtString);
336 AddNew('Tel Pref Work Voice', cfTelPrefWorkVoice, dtString);
337 AddNew('Tel Pref Home Voice', cfTelPrefHomeVoice, dtString);
338 AddNew('Tel Home Voice', cfTelHomeVoice, dtString);
339 AddNew('Tel Work Voice', cfTelWorkVoice, dtString);
340 AddNew('Email Home', cfEmailHome, dtString);
341 AddNew('Email Internet', cfEmailInternet, dtString);
342 AddNew('Nick Name', cfNickName, dtString);
343 AddNew('Note', cfNote, dtString);
344 AddNew('Role', cfRole, dtString);
345 AddNew('Title', cfTitle, dtString);
346 AddNew('Categories', cfCategories, dtString);
347 AddNew('Organization', cfOrganization, dtString);
348 AddNew('Home Address', cfAdrHome, dtString);
349 AddNew('Home Address Street', cfHomeAddressStreet, dtString);
350 AddNew('Home Address City', cfHomeAddressCity, dtString);
351 AddNew('Home Address Country', cfHomeAddressCountry, dtString);
352 AddNew('Times Contacted', cfXTimesContacted, dtString);
353 AddNew('Last Time Contacted', cfXLastTimeContacted, dtString);
354 AddNew('Photo', cfPhoto, dtString);
355 AddNew('Jabber', cfXJabber, dtString);
356 end;
357end;
358
359function TContactsFile.GetFileName: string;
360begin
361 Result := SVCardFile;
362end;
363
364function TContactsFile.GetFileExt: string;
365begin
366 Result := '.vcf';
367end;
368
369function TContactsFile.GetFileFilter: string;
370begin
371 Result := GetFileName + ' (' + GetFileExt + ')|*' + GetFileExt + '|' + inherited;
372end;
373
374procedure TContactsFile.SaveToFile(FileName: string);
375var
376 Output: TStringList;
377 I: Integer;
378 PhotoBase64: string;
379 Line: string;
380
381function IsAsciiString(Text: string): Boolean;
382var
383 I: Integer;
384begin
385 Result := True;
386 for I := 1 to Length(Text) do
387 if Ord(Text[I]) > 128 then begin
388 Result := False;
389 Break;
390 end;
391end;
392
393function NewItem(Key, Value: string): string;
394var
395 Charset: string;
396begin
397 if not IsAsciiString(Value) then Charset := ';CHARSET=UTF-8'
398 else Charset := '';
399 Result := Key + Charset + ':' + Value;
400end;
401
402begin
403 inherited;
404 try
405 Output := TStringList.Create;
406 for I := 0 to Contacts.Count - 1 do
407 with TContact(Contacts[I]), Output do begin
408 Add('BEGIN:VCARD');
409 if Version <> '' then Add('VERSION:' + Version);
410 if XTimesContacted <> '' then Add('X-TIMES_CONTACTED:' + XTimesContacted);
411 if XLastTimeContacted <> '' then Add('X-LAST_TIME_CONTACTED:' + XLastTimeContacted);
412 if (LastName <> '') or (FirstName <> '') or (MiddleName <> '') or (TitleBefore <> '') or (TitleAfter <> '') then
413 Add(NewItem('N', LastName + ';' + FirstName + ';' + MiddleName + ';' + TitleBefore + ';' + TitleAfter));
414 if FullName <> '' then Add(NewItem('FN', FullName));
415 if TelCell <> '' then Add('TEL;CELL:' + TelCell);
416 if TelPrefCell <> '' then Add('TEL;PREF;CELL:' + TelPrefCell);
417 if TelHome <> '' then Add('TEL;HOME:' + TelHome);
418 if TelHome2 <> '' then Add('TEL;HOME2:' + TelHome2);
419 if TelWork <> '' then Add('TEL;WORK:' + TelWork);
420 if TelVoip <> '' then Add('TEL;VOIP:' + TelVoip);
421 if TelPrefWorkVoice <> '' then Add('TEL;PREF;WORK;VOICE:' + TelPrefWorkVoice);
422 if TelPrefHomeVoice <> '' then Add('TEL;PREF;HOME;VOICE:' + TelPrefHomeVoice);
423 if TelHomeVoice <> '' then Add('TEL;HOME;VOICE:' + TelHomeVoice);
424 if TelWorkVoice <> '' then Add('TEL;WORK;VOICE:' + TelWorkVoice);
425 if Note <> '' then Add('NOTE:' + Note);
426 if AdrHome <> '' then Add('ADR;HOME:' + AdrHome);
427 if EmailHome <> '' then Add('EMAIL;HOME:' + EmailHome);
428 if NickName <> '' then Add('X-NICKNAME:' + NickName);
429 if EmailInternet <> '' then Add('EMAIL;INTERNET:' + EmailInternet);
430 if XJabber <> '' then Add('X-JABBER:' + XJabber);
431 if Role <> '' then Add('TITLE:' + Role);
432 if Categories <> '' then Add('CATEGORIES:' + Categories);
433 if Organization <> '' then Add('ORG:' + Organization);
434 if (HomeAddressCity <> '') or (HomeAddressStreet <> '') or
435 (HomeAddressCountry <> '') then Add('ADR;HOME:;;' + HomeAddressStreet + ';' + HomeAddressCity + ';;;' + HomeAddressCountry);
436 if Photo <> '' then begin
437 PhotoBase64 := EncodeStringBase64(Photo);
438
439 Line := Copy(PhotoBase64, 1, 73 - Length('PHOTO;ENCODING=BASE64;JPEG:'));
440 System.Delete(PhotoBase64, 1, Length(Line));
441 Add('PHOTO;ENCODING=BASE64;JPEG:' + Line);
442 while PhotoBase64 <> '' do begin
443 Line := Copy(PhotoBase64, 1, 73);
444 System.Delete(PhotoBase64, 1, Length(Line));
445 Add(' ' + Line);
446 end;
447 Add('');
448 end;
449 Add('END:VCARD');
450 end;
451 Output.SaveToFile(FileName);
452 finally
453 Output.Free;
454 end
455end;
456
457procedure TContactsFile.LoadFromFile(FileName: string);
458var
459 Lines: TStringList;
460 Line: string;
461 I: Integer;
462 NewRecord: TContact;
463 Command: string;
464 CommandPart: string;
465 Charset: string;
466 Encoding: string;
467 Language: string;
468 CommandItems: TStringList;
469begin
470 inherited;
471 Contacts.Clear;
472 Lines := TStringList.Create;
473 Lines.LoadFromFile(FileName);
474 try
475 CommandItems := TStringList.Create;
476 CommandItems.Delimiter := ';';
477 I := 0;
478 while I < Lines.Count do begin
479 Line := Lines[I];
480 if Line = 'BEGIN:VCARD' then begin
481 NewRecord := TContact.Create;
482 NewRecord.Parent := Self;
483 end else
484 if Line = 'END:VCARD' then begin
485 Contacts.Add(NewRecord);
486 NewRecord := nil;
487 end else
488 if Pos(':', Line) > 0 then begin
489 CommandPart := GetNext(Line, ':');
490 CommandItems.DelimitedText := CommandPart;
491 if CommandItems.IndexOfName('CHARSET') >= 0 then begin
492 Charset := CommandItems.Values['CHARSET'];
493 CommandItems.Delete(CommandItems.IndexOfName('CHARSET'));
494 end
495 else if CommandItems.IndexOfName('ENCODING') >= 0 then begin
496 Encoding := CommandItems.Values['ENCODING'];
497 CommandItems.Delete(CommandItems.IndexOfName('ENCODING'));
498 end
499 else if CommandItems.IndexOfName('LANGUAGE') >= 0 then begin
500 Language := CommandItems.Values['LANGUAGE'];
501 CommandItems.Delete(CommandItems.IndexOfName('LANGUAGE'));
502 end;
503 Command := CommandItems.DelimitedText;
504
505 if Command = 'FN' then NewRecord.FullName := Line
506 else if Command = 'N' then begin
507 NewRecord.LastName := GetNext(Line, ';');
508 NewRecord.FirstName := GetNext(Line, ';');
509 NewRecord.MiddleName := GetNext(Line, ';');
510 NewRecord.TitleBefore := GetNext(Line, ';');
511 NewRecord.TitleAfter := GetNext(Line, ';');
512 end
513 else if Command = 'VERSION' then NewRecord.Version := Line
514 else if Command = 'TEL;PREF;CELL' then NewRecord.TelPrefCell := Line
515 else if Command = 'TEL;CELL' then NewRecord.TelCell := Line
516 else if Command = 'TEL;HOME' then NewRecord.TelHome := Line
517 else if Command = 'TEL;HOME2' then NewRecord.TelHome2 := Line
518 else if Command = 'TEL;WORK' then NewRecord.TelWork := Line
519 else if Command = 'TEL;VOIP' then NewRecord.TelVoip := Line
520 else if Command = 'TEL;PREF;WORK;VOICE' then NewRecord.TelPrefWorkVoice := Line
521 else if Command = 'TEL;PREF;HOME;VOICE' then NewRecord.TelPrefHOMEVoice := Line
522 else if Command = 'TEL;HOME;VOICE' then NewRecord.TelHomeVoice := Line
523 else if Command = 'TEL;WORK;VOICE' then NewRecord.TelWorkVoice := Line
524 else if Command = 'ADR;HOME' then NewRecord.AdrHome := Line
525 else if Command = 'X-NICKNAME' then NewRecord.NickName := Line
526 else if Command = 'EMAIL;HOME' then NewRecord.EmailHome := Line
527 else if Command = 'EMAIL;INTERNET' then NewRecord.EmailInternet := Line
528 else if Command = 'NOTE' then NewRecord.Note := Line
529 else if Command = 'ORG' then NewRecord.Organization := Line
530 else if Command = 'X-JABBER' then NewRecord.XJabber := Line
531 else if Command = 'TITLE' then NewRecord.Role := Line
532 else if Command = 'X-TIMES_CONTACTED' then NewRecord.XTimesContacted := Line
533 else if Command = 'X-LAST_TIME_CONTACTED' then NewRecord.XLastTimeContacted := Line
534 else if Command = 'PHOTO;JPEG' then begin
535 NewRecord.Photo := Trim(Line);
536 repeat
537 Inc(I);
538 Line := Trim(Lines[I]);
539 if Line <> '' then NewRecord.Photo := NewRecord.Photo + Line;
540 until Line = '';
541 NewRecord.Photo := DecodeStringBase64(NewRecord.Photo);
542 end
543 else if Assigned(FOnError) then FOnError('Unknown command: ' + Command);
544 end;
545 Inc(I);
546 end;
547 CommandItems.Free;
548 finally
549 Lines.Free;
550 end;
551end;
552
553constructor TContactsFile.Create;
554begin
555 inherited;
556 Contacts := TContacts.Create;
557 Contacts.ContactsFile := Self;
558 Fields := TContactFields.Create;
559 InitFields;
560end;
561
562destructor TContactsFile.Destroy;
563begin
564 FreeAndNil(Fields);
565 FreeAndNil(Contacts);
566 inherited;
567end;
568
569end.
570
Note: See TracBrowser for help on using the repository browser.