1 | unit UContact;
|
---|
2 |
|
---|
3 | {$mode delphi}{$H+}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | Classes, SysUtils, Contnrs, Dialogs, UDataFile, LazUTF8, base64;
|
---|
9 |
|
---|
10 | type
|
---|
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 |
|
---|
116 | implementation
|
---|
117 |
|
---|
118 | resourcestring
|
---|
119 | SVCardFile = 'vCard file';
|
---|
120 | SUnsupportedContactFieldsIndex = 'Unsupported contact field index';
|
---|
121 |
|
---|
122 | { TContacts }
|
---|
123 |
|
---|
124 | function TContacts.AddNew: TContact;
|
---|
125 | begin
|
---|
126 | Result := TContact.Create;
|
---|
127 | Result.Parent := ContactsFile;
|
---|
128 | Add(Result);
|
---|
129 | end;
|
---|
130 |
|
---|
131 | function TContacts.Search(FullName: string): TContact;
|
---|
132 | var
|
---|
133 | Contact: TContact;
|
---|
134 | begin
|
---|
135 | Result := nil;
|
---|
136 | for Contact in Self do
|
---|
137 | if Contact.FullName = FullName then begin
|
---|
138 | Result := Contact;
|
---|
139 | Break;
|
---|
140 | end;
|
---|
141 | end;
|
---|
142 |
|
---|
143 | function TContacts.ToString: ansistring;
|
---|
144 | var
|
---|
145 | I: Integer;
|
---|
146 | begin
|
---|
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;
|
---|
152 | end;
|
---|
153 |
|
---|
154 | { TContactFields }
|
---|
155 |
|
---|
156 | function TContactFields.AddNew(Name: string; Index: TContactFieldIndex;
|
---|
157 | DataType: TDataType): TContactField;
|
---|
158 | begin
|
---|
159 | Result := TContactField.Create;
|
---|
160 | Result.Name := Name;
|
---|
161 | Result.Index := Index;
|
---|
162 | Result.DataType := DataType;
|
---|
163 | Add(Result);
|
---|
164 | end;
|
---|
165 |
|
---|
166 | procedure TContactFields.LoadToStrings(AItems: TStrings);
|
---|
167 | var
|
---|
168 | I: Integer;
|
---|
169 | begin
|
---|
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;
|
---|
174 | end;
|
---|
175 |
|
---|
176 | { TContact }
|
---|
177 |
|
---|
178 | function TContact.GetField(Index: TContactFieldIndex): string;
|
---|
179 | begin
|
---|
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;
|
---|
215 | end;
|
---|
216 |
|
---|
217 | procedure TContact.SetField(Index: TContactFieldIndex; AValue: string);
|
---|
218 | begin
|
---|
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;
|
---|
254 | end;
|
---|
255 |
|
---|
256 | procedure TContact.Assign(Source: TContact);
|
---|
257 | begin
|
---|
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;
|
---|
291 | end;
|
---|
292 |
|
---|
293 | function TContact.UpdateFrom(Source: TContact): Boolean;
|
---|
294 | var
|
---|
295 | I: Integer;
|
---|
296 | begin
|
---|
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;
|
---|
306 | end;
|
---|
307 |
|
---|
308 | { TContactsFile }
|
---|
309 |
|
---|
310 | function TContactsFile.GetNext(var Text: string; Separator: string): string;
|
---|
311 | begin
|
---|
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;
|
---|
319 | end;
|
---|
320 |
|
---|
321 | procedure TContactsFile.InitFields;
|
---|
322 | begin
|
---|
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;
|
---|
357 | end;
|
---|
358 |
|
---|
359 | function TContactsFile.GetFileName: string;
|
---|
360 | begin
|
---|
361 | Result := SVCardFile;
|
---|
362 | end;
|
---|
363 |
|
---|
364 | function TContactsFile.GetFileExt: string;
|
---|
365 | begin
|
---|
366 | Result := '.vcf';
|
---|
367 | end;
|
---|
368 |
|
---|
369 | function TContactsFile.GetFileFilter: string;
|
---|
370 | begin
|
---|
371 | Result := GetFileName + ' (' + GetFileExt + ')|*' + GetFileExt + '|' + inherited;
|
---|
372 | end;
|
---|
373 |
|
---|
374 | procedure TContactsFile.SaveToFile(FileName: string);
|
---|
375 | var
|
---|
376 | Output: TStringList;
|
---|
377 | I: Integer;
|
---|
378 | PhotoBase64: string;
|
---|
379 | Line: string;
|
---|
380 |
|
---|
381 | function IsAsciiString(Text: string): Boolean;
|
---|
382 | var
|
---|
383 | I: Integer;
|
---|
384 | begin
|
---|
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;
|
---|
391 | end;
|
---|
392 |
|
---|
393 | function NewItem(Key, Value: string): string;
|
---|
394 | var
|
---|
395 | Charset: string;
|
---|
396 | begin
|
---|
397 | if not IsAsciiString(Value) then Charset := ';CHARSET=UTF-8'
|
---|
398 | else Charset := '';
|
---|
399 | Result := Key + Charset + ':' + Value;
|
---|
400 | end;
|
---|
401 |
|
---|
402 | begin
|
---|
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
|
---|
455 | end;
|
---|
456 |
|
---|
457 | procedure TContactsFile.LoadFromFile(FileName: string);
|
---|
458 | var
|
---|
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;
|
---|
469 | begin
|
---|
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;
|
---|
551 | end;
|
---|
552 |
|
---|
553 | constructor TContactsFile.Create;
|
---|
554 | begin
|
---|
555 | inherited;
|
---|
556 | Contacts := TContacts.Create;
|
---|
557 | Contacts.ContactsFile := Self;
|
---|
558 | Fields := TContactFields.Create;
|
---|
559 | InitFields;
|
---|
560 | end;
|
---|
561 |
|
---|
562 | destructor TContactsFile.Destroy;
|
---|
563 | begin
|
---|
564 | FreeAndNil(Fields);
|
---|
565 | FreeAndNil(Contacts);
|
---|
566 | inherited;
|
---|
567 | end;
|
---|
568 |
|
---|
569 | end.
|
---|
570 |
|
---|