1 | unit UContactImage;
|
---|
2 |
|
---|
3 | {$mode Delphi}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | Classes, SysUtils, Graphics, UContact, ExtCtrls;
|
---|
9 |
|
---|
10 | type
|
---|
11 | TContactImageFormat = (ifNone, ifBmp, ifJpeg, ifPng, ifGif);
|
---|
12 |
|
---|
13 | { TContactImage }
|
---|
14 |
|
---|
15 | TContactImage = class
|
---|
16 | private
|
---|
17 | FOnChange: TNotifyEvent;
|
---|
18 | FUrl: string;
|
---|
19 | FUsed: Boolean;
|
---|
20 | function GetImageFormat(ContactProperty: TContactProperty): TContactImageFormat;
|
---|
21 | procedure SetUrl(AValue: string);
|
---|
22 | procedure SetUsed(AValue: Boolean);
|
---|
23 | procedure DoOnChange;
|
---|
24 | procedure SaveImageToStream(ImageFormat: TContactImageFormat;
|
---|
25 | Stream: TStream);
|
---|
26 | procedure LoadImageFromStream(ImageFormat: TContactImageFormat;
|
---|
27 | Stream: TStream);
|
---|
28 | public
|
---|
29 | Bitmap: TBitmap;
|
---|
30 | Format: TContactImageFormat;
|
---|
31 | Loaded: Boolean;
|
---|
32 | Modified: Boolean;
|
---|
33 | Contact: TContact;
|
---|
34 | FieldIndex: TContactFieldIndex;
|
---|
35 | procedure Load;
|
---|
36 | procedure Save;
|
---|
37 | procedure Clear;
|
---|
38 | procedure LoadFromFile(FileName: string);
|
---|
39 | procedure SaveToFile(FileName: string);
|
---|
40 | procedure Assign(Source: TContactImage);
|
---|
41 | constructor Create;
|
---|
42 | destructor Destroy; override;
|
---|
43 | property Url: string read FUrl write SetUrl;
|
---|
44 | property Used: Boolean read FUsed write SetUsed;
|
---|
45 | property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
---|
46 | end;
|
---|
47 |
|
---|
48 |
|
---|
49 | implementation
|
---|
50 |
|
---|
51 |
|
---|
52 | { TContactImage }
|
---|
53 |
|
---|
54 | function TContactImage.GetImageFormat(ContactProperty: TContactProperty
|
---|
55 | ): TContactImageFormat;
|
---|
56 | begin
|
---|
57 | if (ContactProperty.Attributes.IndexOf('JPEG') <> -1) or
|
---|
58 | (ContactProperty.Attributes.IndexOf('jpeg') <> -1) then Result := ifJpeg
|
---|
59 | else
|
---|
60 | if (ContactProperty.Attributes.IndexOf('GIF') <> -1) or
|
---|
61 | (ContactProperty.Attributes.IndexOf('gif') <> -1) then Result := ifGif
|
---|
62 | else
|
---|
63 | if (ContactProperty.Attributes.IndexOf('PNG') <> -1) or
|
---|
64 | (ContactProperty.Attributes.IndexOf('png') <> -1) then Result := ifPng
|
---|
65 | else
|
---|
66 | if (ContactProperty.Attributes.IndexOf('BMP') <> -1) or
|
---|
67 | (ContactProperty.Attributes.IndexOf('bmp') <> -1) then Result := ifBmp
|
---|
68 | else
|
---|
69 | Result := ifNone;
|
---|
70 | end;
|
---|
71 |
|
---|
72 | procedure TContactImage.SetUrl(AValue: string);
|
---|
73 | begin
|
---|
74 | if FUrl = AValue then Exit;
|
---|
75 | FUrl := AValue;
|
---|
76 | Modified := True;
|
---|
77 | Used := FUrl <> '';
|
---|
78 | DoOnChange;
|
---|
79 | end;
|
---|
80 |
|
---|
81 | procedure TContactImage.SetUsed(AValue: Boolean);
|
---|
82 | begin
|
---|
83 | if FUsed = AValue then Exit;
|
---|
84 | FUsed := AValue;
|
---|
85 | DoOnChange;
|
---|
86 | end;
|
---|
87 |
|
---|
88 | procedure TContactImage.DoOnChange;
|
---|
89 | begin
|
---|
90 | if Assigned(FOnChange) then
|
---|
91 | FOnChange(Self);
|
---|
92 | end;
|
---|
93 |
|
---|
94 | procedure TContactImage.SaveImageToStream(ImageFormat: TContactImageFormat;
|
---|
95 | Stream: TStream);
|
---|
96 | var
|
---|
97 | JpegImage: TJpegImage;
|
---|
98 | PngImage: TPortableNetworkGraphic;
|
---|
99 | GifImage: TGIFImage;
|
---|
100 | begin
|
---|
101 | if ImageFormat = ifJpeg then begin
|
---|
102 | JpegImage := TJPEGImage.Create;
|
---|
103 | try
|
---|
104 | try
|
---|
105 | JpegImage.SetSize(Bitmap.Width, Bitmap.Height);
|
---|
106 | JpegImage.Canvas.Draw(0, 0, Bitmap);
|
---|
107 | JpegImage.SaveToStream(Stream);
|
---|
108 | except
|
---|
109 | end;
|
---|
110 | finally
|
---|
111 | JpegImage.Free;
|
---|
112 | end;
|
---|
113 | end else
|
---|
114 | if ImageFormat = ifPng then begin
|
---|
115 | PngImage := TPortableNetworkGraphic.Create;
|
---|
116 | try
|
---|
117 | try
|
---|
118 | PngImage.SetSize(Bitmap.Width, Bitmap.Height);
|
---|
119 | PngImage.Canvas.Draw(0, 0, Bitmap);
|
---|
120 | PngImage.SaveToStream(Stream);
|
---|
121 | except
|
---|
122 | end;
|
---|
123 | finally
|
---|
124 | PngImage.Free;
|
---|
125 | end;
|
---|
126 | end else
|
---|
127 | if ImageFormat = ifGif then begin
|
---|
128 | GifImage := TGIFImage.Create;
|
---|
129 | try
|
---|
130 | try
|
---|
131 | GifImage.SetSize(Bitmap.Width, Bitmap.Height);
|
---|
132 | GifImage.Canvas.Draw(0, 0, Bitmap);
|
---|
133 | GifImage.SaveToStream(Stream);
|
---|
134 | except
|
---|
135 | end;
|
---|
136 | finally
|
---|
137 | GifImage.Free;
|
---|
138 | end;
|
---|
139 | end else
|
---|
140 | if ImageFormat = ifBmp then begin
|
---|
141 | try
|
---|
142 | Bitmap.SaveToStream(Stream);
|
---|
143 | except
|
---|
144 | end;
|
---|
145 | end else begin
|
---|
146 | // Use default type
|
---|
147 | SaveImageToStream(ifJpeg, Stream);
|
---|
148 | end;
|
---|
149 | end;
|
---|
150 |
|
---|
151 | procedure TContactImage.LoadImageFromStream(ImageFormat: TContactImageFormat;
|
---|
152 | Stream: TStream);
|
---|
153 | var
|
---|
154 | JpegImage: TJpegImage;
|
---|
155 | PngImage: TPortableNetworkGraphic;
|
---|
156 | GifImage: TGIFImage;
|
---|
157 | BmpImage: TBitmap;
|
---|
158 | begin
|
---|
159 | if ImageFormat = ifJpeg then begin
|
---|
160 | try
|
---|
161 | JpegImage := TJPEGImage.Create;
|
---|
162 | try
|
---|
163 | JpegImage.LoadFromStream(Stream);
|
---|
164 | with Bitmap do begin
|
---|
165 | PixelFormat := pf24bit;
|
---|
166 | SetSize(JpegImage.Width, JpegImage.Height);
|
---|
167 | Canvas.Draw(0, 0, JpegImage);
|
---|
168 | end;
|
---|
169 | finally
|
---|
170 | JpegImage.Free;
|
---|
171 | end;
|
---|
172 | Used := True;
|
---|
173 | except
|
---|
174 | Used := False;
|
---|
175 | end;
|
---|
176 | end else
|
---|
177 | if ImageFormat = ifPng then begin
|
---|
178 | try
|
---|
179 | PngImage := TPortableNetworkGraphic.Create;
|
---|
180 | try
|
---|
181 | PngImage.LoadFromStream(Stream);
|
---|
182 | with Bitmap do begin
|
---|
183 | PixelFormat := pf24bit;
|
---|
184 | SetSize(PngImage.Width, PngImage.Height);
|
---|
185 | Canvas.Draw(0, 0, PngImage);
|
---|
186 | end;
|
---|
187 | finally
|
---|
188 | PngImage.Free;
|
---|
189 | end;
|
---|
190 | Used := True;
|
---|
191 | except
|
---|
192 | Used := False;
|
---|
193 | end;
|
---|
194 | end else
|
---|
195 | if ImageFormat = ifGif then begin
|
---|
196 | try
|
---|
197 | GifImage := TGIFImage.Create;
|
---|
198 | try
|
---|
199 | GifImage.LoadFromStream(Stream);
|
---|
200 | with Bitmap do begin
|
---|
201 | PixelFormat := pf24bit;
|
---|
202 | SetSize(GifImage.Width, GifImage.Height);
|
---|
203 | Canvas.Draw(0, 0, GifImage);
|
---|
204 | end;
|
---|
205 | finally
|
---|
206 | GifImage.Free;
|
---|
207 | end;
|
---|
208 | Used := True;
|
---|
209 | except
|
---|
210 | Used := False;
|
---|
211 | end;
|
---|
212 | end else
|
---|
213 | if ImageFormat = ifBmp then begin
|
---|
214 | try
|
---|
215 | BmpImage := TBitmap.Create;
|
---|
216 | try
|
---|
217 | BmpImage.LoadFromStream(Stream);
|
---|
218 | with Bitmap do begin
|
---|
219 | PixelFormat := pf24bit;
|
---|
220 | SetSize(BmpImage.Width, BmpImage.Height);
|
---|
221 | Canvas.Draw(0, 0, BmpImage);
|
---|
222 | end;
|
---|
223 | finally
|
---|
224 | BmpImage.Free;
|
---|
225 | end;
|
---|
226 | Used := True;
|
---|
227 | except
|
---|
228 | Used := False;
|
---|
229 | end;
|
---|
230 | end else begin
|
---|
231 | // Unknown image type, let TPicture guess what it is
|
---|
232 | try
|
---|
233 | with TImage.Create(nil) do
|
---|
234 | try
|
---|
235 | Picture.LoadFromStream(Stream);
|
---|
236 | with Bitmap do begin
|
---|
237 | PixelFormat := pf24bit;
|
---|
238 | SetSize(Picture.Bitmap.Width, Picture.Bitmap.Height);
|
---|
239 | Canvas.Draw(0, 0, Picture.Bitmap);
|
---|
240 | end;
|
---|
241 | finally
|
---|
242 | Free;
|
---|
243 | end;
|
---|
244 | Used := True;
|
---|
245 | except
|
---|
246 | Used := False;
|
---|
247 | end;
|
---|
248 | end;
|
---|
249 | end;
|
---|
250 |
|
---|
251 | procedure TContactImage.Load;
|
---|
252 | var
|
---|
253 | PhotoProperty: TContactProperty;
|
---|
254 | Photo: string;
|
---|
255 | Stream: TMemoryStream;
|
---|
256 | begin
|
---|
257 | PhotoProperty := Contact.GetProperty(FieldIndex);
|
---|
258 | if not Loaded then begin
|
---|
259 | if Assigned(PhotoProperty) then begin
|
---|
260 | Loaded := True;
|
---|
261 | Modified := True;
|
---|
262 | Photo := Contact.Fields[FieldIndex];
|
---|
263 | if (Photo <> '') and (PhotoProperty.Encoding <> '') then begin
|
---|
264 | Stream := TMemoryStream.Create;
|
---|
265 | try
|
---|
266 | Stream.Write(Photo[1], Length(Photo));
|
---|
267 | Stream.Position := 0;
|
---|
268 | LoadImageFromStream(GetImageFormat(PhotoProperty), Stream);
|
---|
269 | finally
|
---|
270 | Stream.Free;
|
---|
271 | end;
|
---|
272 | end else begin
|
---|
273 | Url := Photo;
|
---|
274 | Used := True;
|
---|
275 | end;
|
---|
276 | end else Used := False;
|
---|
277 | end;
|
---|
278 | end;
|
---|
279 |
|
---|
280 | procedure TContactImage.Save;
|
---|
281 | var
|
---|
282 | PhotoProperty: TContactProperty;
|
---|
283 | Photo: string;
|
---|
284 | Stream: TMemoryStream;
|
---|
285 | begin
|
---|
286 | if Modified then begin
|
---|
287 | if Used then begin
|
---|
288 | PhotoProperty := Contact.GetProperty(FieldIndex);
|
---|
289 | if not Assigned(PhotoProperty) then begin
|
---|
290 | PhotoProperty := TContactProperty.Create;
|
---|
291 | PhotoProperty.Name := 'PHOTO';
|
---|
292 | PhotoProperty.Attributes.DelimitedText := 'JPEG';
|
---|
293 | Contact.Properties.Add(PhotoProperty);
|
---|
294 | end;
|
---|
295 | if Url <> '' then begin
|
---|
296 | Contact.Fields[FieldIndex] := Url;
|
---|
297 | PhotoProperty.Encoding := '';
|
---|
298 | end else begin
|
---|
299 | PhotoProperty.Encoding := VCardBase64;
|
---|
300 | Stream := TMemoryStream.Create;
|
---|
301 | try
|
---|
302 | SaveImageToStream(GetImageFormat(PhotoProperty), Stream);
|
---|
303 | Photo := '';
|
---|
304 | SetLength(Photo, Stream.Size);
|
---|
305 | Stream.Position := 0;
|
---|
306 | Stream.Read(Photo[1], Length(Photo));
|
---|
307 | Contact.Fields[FieldIndex] := Photo;
|
---|
308 | finally
|
---|
309 | Stream.Free;
|
---|
310 | end;
|
---|
311 | end;
|
---|
312 | end else begin
|
---|
313 | PhotoProperty := Contact.GetProperty(FieldIndex);
|
---|
314 | if Assigned(PhotoProperty) then
|
---|
315 | Contact.Properties.Remove(PhotoProperty);
|
---|
316 | end;
|
---|
317 | Modified := False;
|
---|
318 | end;
|
---|
319 | end;
|
---|
320 |
|
---|
321 | procedure TContactImage.Clear;
|
---|
322 | begin
|
---|
323 | Url := '';
|
---|
324 | Used := False;
|
---|
325 | Modified := True;
|
---|
326 | end;
|
---|
327 |
|
---|
328 | procedure TContactImage.LoadFromFile(FileName: string);
|
---|
329 | begin
|
---|
330 | with TImage.Create(nil) do
|
---|
331 | try
|
---|
332 | Picture.LoadFromFile(FileName);
|
---|
333 | Bitmap.Assign(Picture.Bitmap);
|
---|
334 | Url := '';
|
---|
335 | Used := True;
|
---|
336 | Modified := True;
|
---|
337 | finally
|
---|
338 | Free;
|
---|
339 | end;
|
---|
340 | end;
|
---|
341 |
|
---|
342 | procedure TContactImage.SaveToFile(FileName: string);
|
---|
343 | begin
|
---|
344 | with TImage.Create(nil) do
|
---|
345 | try
|
---|
346 | Picture.Bitmap.Assign(Bitmap);
|
---|
347 | Picture.SaveToFile(FileName);
|
---|
348 | finally
|
---|
349 | Free;
|
---|
350 | end;
|
---|
351 | end;
|
---|
352 |
|
---|
353 | procedure TContactImage.Assign(Source: TContactImage);
|
---|
354 | begin
|
---|
355 | Bitmap.Assign(Source.Bitmap);
|
---|
356 | Url := Source.Url;
|
---|
357 | Loaded := Source.Loaded;
|
---|
358 | Modified := Source.Modified;
|
---|
359 | Format := Source.Format;
|
---|
360 | FieldIndex := Source.FieldIndex;
|
---|
361 | Contact := Source.Contact;
|
---|
362 | Used := Source.Used;
|
---|
363 | end;
|
---|
364 |
|
---|
365 | constructor TContactImage.Create;
|
---|
366 | begin
|
---|
367 | Bitmap := TBitmap.Create;
|
---|
368 | end;
|
---|
369 |
|
---|
370 | destructor TContactImage.Destroy;
|
---|
371 | begin
|
---|
372 | FreeAndNil(Bitmap);
|
---|
373 | inherited;
|
---|
374 | end;
|
---|
375 |
|
---|
376 |
|
---|
377 | end.
|
---|
378 |
|
---|