Уважаемые авторы вопросов! Большая просьба сообщить о результатах решения проблемы на этой странице. Иначе, следящие за обсуждением, возможно имеющие аналогичные проблемы, не получают ясного представления об их решении. А авторы ответов не получают обратной связи. Что можно расценивать, как проявление неуважения к отвечающим от автора вопроса.
02-11-2006 00:40 | Сообщение от автора вопроса
Фух... получил почту, а там стока сообщений %)...
Я аж испугался...
У меня отлично работает сейчас - если что, смотрите начало топика.
procedure TAPDBImage.LoadPicture;
begin
with FDataLink, Field, Picture do
if not FPictureLoaded and (not Assigned(Field) or IsBlob) then
if (Field = nil) or (TBlobField(Field).BlobSize = 0) then Graphic := nil
else
begin
Graphic := FindGraphicClass.Create;
Graphic.Assign(FDataLink.Field)
end
end;
procedure TAPDBImage.UpdateData(Sender: TObject);
var bs: TStream;
Jpg: TJpegImage;
Bmp: TBitmap;
begin
with Picture, FDataLink do
begin
bs := DataSet.CreateBlobStream(TBlobField(FDataLink.Field), bmWrite);
try
Graphic.SaveToStream(bs)
finally
bs.Free
end
end
end;
Функция FindGraphicClass должна возвращать TGraphicClass (откуда она его будет брать - решай сам или из поля в базе или ты будешь сам парсить BLOB)
Просто я не знаю , какого формата будут данные в этих полях они могут быть не только в png, но и .gif , .jpeg, .bmp, .tiff и.т.д. то есть разных форматов изображения...
Стоп, ну, конечно, возможно, TAPDBImage умеет читать только jpg-формат с базы, и все форматы на вход. Можете поменять методы LoadPicture, UpdateData для работы с PNG, дело в том, что сам по себе поток не хранит в себе инфы о своем формате (вернее парсить влом заголовки).
19-06-2006 08:50 | Комментарий к предыдущим ответам
2Игорь
Или Вы станете утверждать, что разработчики сторонних контролов, заменяющих стандартные, для расширения их функциональности, но не наследую оных - то же не знают ООП? Да, так вышло, что изменение какжется небольшим - но довольно глубоким - я не виноват, что нужные для перекрытия методы не были сделаны виртуальными в TDBImage.
19-06-2006 08:46 | Комментарий к предыдущим ответам
Объясняю, если возьмете код исходного TDBImage и сравните его с этим - увидите такую маленькую деталь - перекрыты статические (иногда еще и private) методы. Т.е. наследование - отпадает, агрегация тем более неприменима, потому что контрол дергается через DataLink и его поведение обусловлено именно теми статическими вызовами, которые я переписал для работы с JPG форматом. Это не развитие компонента TDBImage, это его другая версия. И, пожалуйста, впредь не следует что-то критиковать до конца не разобравшись - а почему оно так, а не иначе.
19-06-2006 08:31 | Комментарий к предыдущим ответам
To Banderas
Я считаю, что простое копирование исходного кода класса TDBImage, объявленного в модуле DBCtrls, в свой класс - это не ООП. Хотите расширить функциональность класса - используйте наследование или агрегацию.
19-06-2006 07:51 | Комментарий к предыдущим ответам
2Игорь
Я на вашем месте пошел бы заново ООП изучать, а не выкладывал бы на всеобщее обозрение такие сомнительные "модификации", которые только вводят в заблуждение начинающих программистов и вырабатывают у них дурной подход в написании программ.
Можно по-подробнее насчет моих недостатков в знании ООП? И насчет сомнительности модификаций? Обоснуйте, если Вас не затруднит :) Вашу критику.
>>>To Banderas
Я на вашем месте пошел бы заново ООП изучать, а не выкладывал бы на всеобщее обозрение такие сомнительные "модификации", которые только вводят в заблуждение начинающих программистов и вырабатывают у них дурной подход в написании программ.
function TAPDBImage.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TAPDBImage.SetDataSource(Value: TDataSource);
begin
if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
function TAPDBImage.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TAPDBImage.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TAPDBImage.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
procedure TAPDBImage.SetReadOnly(Value: Boolean);
begin
FDataLink.ReadOnly := Value;
end;
function TAPDBImage.GetField: TField;
begin
Result := FDataLink.Field;
end;
function TAPDBImage.GetPalette: HPALETTE;
begin
Result := 0;
if FPicture.Graphic is TBitmap then
Result := TBitmap(FPicture.Graphic).Palette;
end;
procedure TAPDBImage.SetAutoDisplay(Value: Boolean);
begin
if FAutoDisplay <> Value then
begin
FAutoDisplay := Value;
if Value then LoadPicture;
end;
end;
procedure TAPDBImage.SetBorderStyle(Value: TBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
RecreateWnd;
end;
end;
procedure TAPDBImage.SetCenter(Value: Boolean);
begin
if FCenter <> Value then
begin
FCenter := Value;
Invalidate;
end;
end;
procedure TAPDBImage.SetPicture(Value: TPicture);
begin
FPicture.Assign(Value);
end;
procedure TAPDBImage.SetStretch(Value: Boolean);
begin
if FStretch <> Value then
begin
FStretch := Value;
Invalidate;
end;
end;
procedure TAPDBImage.Paint;
var
Size: TSize;
R: TRect;
S: string;
DrawPict: TPicture;
Form: TCustomForm;
Pal: HPalette;
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := Color;
if FPictureLoaded or (csPaintCopy in ControlState) then
begin
DrawPict := TPicture.Create;
Pal := 0;
try
if (csPaintCopy in ControlState) and
Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
begin
DrawPict.Assign(FDataLink.Field);
if DrawPict.Graphic is TBitmap then
DrawPict.Bitmap.IgnorePalette := QuickDraw
end
else
begin
DrawPict.Assign(Picture);
if Focused and (DrawPict.Graphic <> nil) and (DrawPict.Graphic.Palette <> 0) then
begin { Control has focus, so realize the bitmap palette in foreground }
Pal := SelectPalette(Handle, DrawPict.Graphic.Palette, False);
RealizePalette(Handle);
end;
end;
if Stretch then
if (DrawPict.Graphic = nil) or DrawPict.Graphic.Empty then
FillRect(ClientRect)
else
StretchDraw(ClientRect, DrawPict.Graphic)
else
begin
SetRect(R, 0, 0, DrawPict.Width, DrawPict.Height);
if Center then OffsetRect(R, (ClientWidth - DrawPict.Width) div 2,
(ClientHeight - DrawPict.Height) div 2);
StretchDraw(R, DrawPict.Graphic);
ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
FillRect(ClientRect);
SelectClipRgn(Handle, 0);
end;
finally
if Pal <> 0 then SelectPalette(Handle, Pal, True);
DrawPict.Free;
end;
end
else begin
Font := Self.Font;
if FDataLink.Field <> nil then
S := FDataLink.Field.DisplayLabel
else S := Name;
S := '(' + S + ')';
Size := TextExtent(S);
R := ClientRect;
TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);
end;
Form := GetParentForm(Self);
if (Form <> nil) and (Form.ActiveControl = Self) and
not (csDesigning in ComponentState) and
not (csPaintCopy in ControlState) then
begin
Brush.Color := clWindowFrame;
FrameRect(ClientRect);
end;
end;
end;
procedure TAPDBImage.PictureChanged(Sender: TObject);
begin
if FPictureLoaded then FDataLink.Modified;
FPictureLoaded := True;
Invalidate;
end;
procedure TAPDBImage.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TAPDBImage.LoadPicture;
begin
with FDataLink, Field, Picture do
if not FPictureLoaded and (not Assigned(Field) or IsBlob) then
if (Field = nil) or (TBlobField(Field).BlobSize = 0) then Graphic := nil
else
begin
Graphic := TJpegImage.Create;
Graphic.Assign(FDataLink.Field)
end
end;
procedure TAPDBImage.DataChange(Sender: TObject);
begin
Picture.Graphic := nil;
FPictureLoaded := False;
if FAutoDisplay then LoadPicture;
end;
procedure TAPDBImage.UpdateData(Sender: TObject);
var bs: TStream;
Jpg: TJpegImage;
Bmp: TBitmap;
begin
with Picture, FDataLink do
begin
bs := DataSet.CreateBlobStream(TBlobField(FDataLink.Field), bmWrite);
try
if Graphic is TJpegImage then Graphic.SaveToStream(bs)
else
begin
Jpg := TJpegImage.Create;
with Jpg do
try
CompressionQuality := 100;
PixelFormat := jf24bit;
if Graphic is TBitmap then Assign(Graphic)
else
begin
Bmp := TBitmap.Create;
try
Bmp.Width := Graphic.Width;
Bmp.Height := Graphic.Height;
Bmp.Canvas.Draw(0, 0, Graphic);
Assign(Bmp)
finally
Bmp.Free
end
end;
JPEGNeeded;
SaveToStream(bs);
finally
Free
end
end
finally
bs.Free
end
end
end;
procedure TAPDBImage.CopyToClipboard;
begin
if Picture.Graphic <> nil then Clipboard.Assign(Picture);
end;
procedure TAPDBImage.CutToClipboard;
begin
if Picture.Graphic <> nil then
if FDataLink.Edit then
begin
CopyToClipboard;
Picture.Graphic := nil;
end;
end;
procedure TAPDBImage.PasteFromClipboard;
begin
if FDataLink.Edit then
Picture.Assign(Clipboard);
end;
procedure TAPDBImage.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
if FBorderStyle = bsSingle then
if NewStyleControls and Ctl3D then
ExStyle := ExStyle or WS_EX_CLIENTEDGE
else
Style := Style or WS_BORDER;
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
procedure TAPDBImage.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
case Key of
VK_INSERT:
if ssShift in Shift then PasteFromClipBoard else
if ssCtrl in Shift then CopyToClipBoard;
VK_DELETE:
if ssShift in Shift then CutToClipBoard;
end;
end;
procedure TAPDBImage.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
case Key of
^X: CutToClipBoard;
^C: CopyToClipBoard;
^V: PasteFromClipBoard;
#13: LoadPicture;
#27: FDataLink.Reset;
end;
end;
procedure TAPDBImage.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink)
end;
procedure TAPDBImage.CMEnter(var Message: TCMEnter);
begin
Invalidate; { Draw the focus marker }
inherited;
end;
procedure TAPDBImage.CMExit(var Message: TCMExit);
begin
try
if Assigned(DataSource) and Assigned(DataSource.DataSet) and
(DataSource.DataSet.State in [dsInsert, dsEdit]) then
FDataLink.UpdateRecord;
except
SetFocus;
raise;
end;
Invalidate; { Erase the focus marker }
inherited;
end;
procedure TAPDBImage.CMTextChanged(var Message: TMessage);
begin
inherited;
if not FPictureLoaded then Invalidate;
end;
procedure TAPDBImage.WMLButtonDown(var Message: TWMLButtonDown);
begin
if TabStop and CanFocus then SetFocus;
inherited;
end;
procedure TAPDBImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
LoadPicture;
inherited;
end;
procedure TAPDBImage.WMCut(var Message: TMessage);
begin
CutToClipboard;
end;
procedure TAPDBImage.WMCopy(var Message: TMessage);
begin
CopyToClipboard;
end;
procedure TAPDBImage.WMPaste(var Message: TMessage);
begin
PasteFromClipboard;
end;
procedure TAPDBImage.WMSize(var Message: TMessage);
begin
inherited;
Invalidate;
end;
function TAPDBImage.ExecuteAction(Action: TBasicAction): Boolean;
begin
Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
FDataLink.ExecuteAction(Action);
end;
function TAPDBImage.UpdateAction(Action: TBasicAction): Boolean;
begin
Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
FDataLink.UpdateAction(Action);
end;
procedure Register;
begin
RegisterComponents('AP Corp', [TAPDBImage]);
end;
Если вы заметили орфографическую ошибку на этой странице, просто выделите ошибку мышью и нажмите Ctrl+Enter. Функция может не работать в некоторых версиях броузеров.
