resim ekleme ve okuma

Diğer veritabanları ve SQL komutlarıyla ilgli sorularınızı sorabilirsiniz. Delphi tarafındaki sorularınızı lütfen Programlama forumunda sorunuz.
akuyumcu63
Üye
Mesajlar: 386
Kayıt: 02 Tem 2007 09:43

resim ekleme ve okuma

Mesaj gönderen akuyumcu63 »

değerli arkadaşlar;

veri tabanından veri okurken yada veri tabanına veri aktarırken ben aşağıdaki yöntemi kullanıyorum.

CXCOMBOBOX5.Text :=DM.ADSTBLSTOKGRUBU.AsString;
DM.ADSTBLSTOKGRUBU.AsString := CXCOMBOBOX5.Text;

yukarıdaki kod sistemini veri tabanından resim verisi okurken yada resmi kaydederken nasıl kullanabilirim. resmi cximage ye alabiliyorum ancak kaydetme ve okuma işlemini yukarıdaki kod sisteminde olduğu gibi yapamadım.

delphi 7, advantage veri tabanı ve cximage kullanıyorum.

kolay gelsin,
İsteyen, yapabildiğinden daha fazlasını yapar.
Kullanıcı avatarı
unicorn64
Üye
Mesajlar: 919
Kayıt: 04 Nis 2006 08:56
Konum: yine yeniden Ankara ^_^

Re: resim ekleme ve okuma

Mesaj gönderen unicorn64 »

image i parametre olarak aktarabilirsin.
2 hafta önce banada lazım olmuştu. sql serverdaki tabloya resmi blob alana kaydettim ancak kodlar işyerinde yarın musait olursam kodları yollarım. createblobparameter yada createblob.. gibi bişiler vardı tam çıkaramadım şimdi...
bazen yükselmek için önce dibi görmek gerekir...

forumda soru sormadan önce bakılmalı bence
daha fazlası için...

yürümeyi öğrenmeden koşmaya çalışanlar için, tökezleyip düşmek kaçınılmazdır...

Resim
akuyumcu63
Üye
Mesajlar: 386
Kayıt: 02 Tem 2007 09:43

Re: resim ekleme ve okuma

Mesaj gönderen akuyumcu63 »

yardımlarınız için şimdiden teşekkür ederim. kodu bekliyorum.
İsteyen, yapabildiğinden daha fazlasını yapar.
Kullanıcı avatarı
unicorn64
Üye
Mesajlar: 919
Kayıt: 04 Nis 2006 08:56
Konum: yine yeniden Ankara ^_^

Re: resim ekleme ve okuma

Mesaj gönderen unicorn64 »

Kod: Tümünü seç


var
ResimStream :TMemoryStream;


 ResimStream := TMemoryStream.Create;
        ResimStream.CopyFrom(ResimData, ResimData.Size);
        //ResimAQ.Close;
        ResimAQ.SQL.text := '';
        ResimAQ.SQL.Add('INSERT INTO _TBLPENETRASYONRESIM (GUID_FISNO,RESIM_DATA) VALUES(''' + GUID_FISNO + ''',:RESIM_DATA) ');
        with ResimAQ.Parameters.AddParameter do
        begin
          DataType := ftBlob;
          Direction := pdInput;
          LoadFromStream(ResimStream, ftBlob);
        end;

        ResimAQ.Connection := ResimAC;
        ResimAQ.ExecSQL;


ResimData kullandığımız bileşen üzerinden tanımlı stream tipli değişken. sen filestream kullanarak resmi alabilirsin.
bazen yükselmek için önce dibi görmek gerekir...

forumda soru sormadan önce bakılmalı bence
daha fazlası için...

yürümeyi öğrenmeden koşmaya çalışanlar için, tökezleyip düşmek kaçınılmazdır...

Resim
haznedarli
Üye
Mesajlar: 122
Kayıt: 31 Tem 2010 06:38

Re: resim ekleme ve okuma

Mesaj gönderen haznedarli »

kolay gelsin umarım cevap gelir :=)
ben de bir soru sorayım dedim anlıyacagım dilden olursa sevinirim.
şimdi bir muhasebe programı var reklam olmasın isim vemiyecegim
bu programda stok kartı var ürün ekliyorsun resim ekliyorsun stok kartında sorun yok
databaseye Firebird Maestro ile bağlanınca resim_yolu boş bir veri yok ama programda görünüyor sorunsuz neden dertlendim derseniz asp sayfa yapıyorum resim yolunu gösteriyorum resimi bulamıyor çünki boş resmi dbden asp yolla nasıl çekerim yardımcı olabilirmisiniz.
mkysoft
Kıdemli Üye
Mesajlar: 3103
Kayıt: 26 Ağu 2003 12:35
Konum: Berlin
İletişim:

Re: resim ekleme ve okuma

Mesaj gönderen mkysoft »

belkide kullanılmayan bir alandır. veri tabanında blob alanları kontrol ediniz.
haznedarli
Üye
Mesajlar: 122
Kayıt: 31 Tem 2010 06:38

Re: resim ekleme ve okuma

Mesaj gönderen haznedarli »

blob dedigini anlıyamadım ama kullanılmıyan bir alansa ben programda nasıl ekledigim resimi görebiliyorum transfer diye bir olay var orada yer falan belirtirken diyorki resimleri db ye yazar ama neresine yazdıgını bir türlü bulamadım ki ona resimi ekle tekrar siteye ekle çok ama çok uzun bir bir :D 20000 kalem mal var aşayukarı db de şu anda okadar degil ama çok yakın bir zamanda geçme ihtimali birle var..
haznedarli
Üye
Mesajlar: 122
Kayıt: 31 Tem 2010 06:38

Re: resim ekleme ve okuma

Mesaj gönderen haznedarli »

program adı vereyim bari olmıyacak başka türlü sanırım :=)
şimdi arkadaşlar wolvox kullanıyoruz buna asp olarak bir site entegre etmeye çelışıyorum ve bitti sayılır muhasebe programında stok kartını açıyorum resim ekle diyor reim yolunu gösteriyorum ve gayet başarılı bir şekilde gösteriyor klasöre falan yazmıyor db nin içine direk yazıyormuş db yi alt üst ettim bulamadım nerede oldugunu db de stok kartılarını açıyorum orada resim yolu tablosu var onu açıyoum içi bom boş bir şey yok ama stok kartını açınca resim var programda bu işi nasıl çözerim yardımlarınıza ihtiyacım var şimdiden teşekkürler..
anemos
Üye
Mesajlar: 110
Kayıt: 02 Nis 2007 07:51
Konum: Sakarya / Hendek

Re: resim ekleme ve okuma

Mesaj gönderen anemos »

Merhaba,

A*soft sisteminde ikinci bir veritabanı daha var; ona baktınız mı?
haznedarli
Üye
Mesajlar: 122
Kayıt: 31 Tem 2010 06:38

Re: resim ekleme ve okuma

Mesaj gönderen haznedarli »

bakmadım onada bakayım :=) belki de ondadır o şirket diye bir db diye onu kaydeye almamıştım :=)))
umarım işe yarar şimdiden teşekkür ederim işe yaramassa yazarım gene :=)
haznedarli
Üye
Mesajlar: 122
Kayıt: 31 Tem 2010 06:38

Re: resim ekleme ve okuma

Mesaj gönderen haznedarli »

evet haklıymışşın ayrı bir db de tutuyor resmi şimdi söyle bir sorun var bunada yardımcı olabilirsen sevinirim db ayrı mesele yok bağlantı kurarız da
stok kartının db id yok blkodu var id yerine geçen blkodu örnek

7289 ama resim dosyasında blkodu 15 oldu bağkodu diye bir yervar orası onunla irtibata geçiyor fakat ordada şu yazıyor

wo_stlogo_17289 burada asp de wo_stlogo_1 alma dan nasıl bağlantı kurduracagım..
haznedarli
Üye
Mesajlar: 122
Kayıt: 31 Tem 2010 06:38

Re: resim ekleme ve okuma

Mesaj gönderen haznedarli »

akınsoft wolvox kullanıyorum db si firebird ben asp ile netten bağlanıyorum dosya.fdb db adı

CREATE TABLE DOSYA (
BLKODU DOUBLE PRECISION NOT NULL,
BAGKODU VARCHAR(30) CHARACTER SET WIN1254 COLLATE WIN1254,
DOSYAADI VARCHAR(75) CHARACTER SET WIN1254 COLLATE PXW_TURK,
ACIKLAMA VARCHAR(100) CHARACTER SET WIN1254 COLLATE PXW_TURK,
FILEDATA BLOB,
OZELKODU VARCHAR(30) CHARACTER SET WIN1254 COLLATE PXW_TURK);

ALTER TABLE DOSYA ADD PRIMARY KEY (BLKODU);

CREATE INDEX DOSYA_BAGKODU ON DOSYA(BAGKODU);

resimler dosya adında sadece dosyanın adı var ama başka bir şekilde resimler görünmüyor dll kodları bunlar bu dosyayı ben nasıl sitede göstere bilirim şimdiden herkese teşekkürler..
akuyumcu63
Üye
Mesajlar: 386
Kayıt: 02 Tem 2007 09:43

Re: resim ekleme ve okuma

Mesaj gönderen akuyumcu63 »

merhaba;

unicorn64 kardeşim, resimlerle ilgili formda araştırma yapıyordum. 2008 yılında sorduğum bir sorumu gördüm. kodu beklediğimi yazmışım. üzerinden çok zaman geçmiş.
incelik gösterip kodu yazmışsınız.
fark ettim de teşekkür etmeyi unutmuşum. kabul ederseniz şimdi teşekkür etmek istiyorum.

kolay gelsin
İsteyen, yapabildiğinden daha fazlasını yapar.
Kullanıcı avatarı
ender_arslanturk
Kıdemli Üye
Mesajlar: 709
Kayıt: 18 Şub 2005 03:38
Konum: İstanbul

Re: resim ekleme ve okuma

Mesaj gönderen ender_arslanturk »

Resim olarak kayıt etme yerine datasını kayıt edebilirsiniz..

Kod: Tümünü seç

unit ads_GraphicStrings;
{Copyright(c)2000 Advanced Delphi Systems

Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
maley@advdelphisys.com

The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to maley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}

(*
Description: ads_GraphicStrings
This unit contains functions for converting
graphic images to and from strings. The string
format is the same as that which is used by dfm
files.
*)

interface
Uses Graphics, Controls;

Function BitmapToString_ads(Bitmap: TBitmap): String;
Function StringToBitmap_ads(Bitmap: TBitmap; BitmapString: String): Boolean;
Function PictureToString_ads(Picture: TPicture): String;
Function StringToPicture_ads(Picture: TPicture; PictureString: String): Boolean;
Function GlyphToString_ads(Glyph: TBitmap): String;
Function StringToGlyph_ads(Glyph: TBitmap; GlyphString: String): Boolean;
Function StringToIcon_ads(Icon: TIcon; IconString: String): Boolean;

Function ImageListToString_ads(ImageList: TImageList): String;
Function StringToImageList_ads(Var ImageList: TImageList; ImageListString: String): Boolean;



implementation
Uses
Classes,
SysUtils,
Dialogs,
ads_Exception;

Var
UnitName : String;
ProcName : String;

Type
TIcon_ads = Class(TComponent)
private
FIcon: TIcon;
procedure SetIcon(const Value: TIcon);
public
Constructor Create(AOwner: TComponent); Override;
Destructor Destroy; Override;
published
property Icon : TIcon read FIcon write SetIcon;
End;

constructor TIcon_ads.Create(AOwner: TComponent);
begin
ProcName := 'TIcon_ads.Create'; Try
inherited;
FIcon := TIcon.Create();
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

destructor TIcon_ads.Destroy;
begin
ProcName := 'TIcon_ads.Destroy'; Try
Try FIcon.Free; Except End;
inherited;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TIcon_ads.SetIcon(const Value: TIcon);
begin
ProcName := 'TIcon_ads.SetIcon'; Try
If FIcon <> Value Then FIcon := Value;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Type
TBitmap_ads = Class(TComponent)
private
FBitmap: TBitmap;
procedure SetBitmap(const Value: TBitmap);
public
Constructor Create(AOwner: TComponent); Override;
Destructor Destroy; Override;
published
property Bitmap : TBitmap read FBitmap write SetBitmap;
End;

constructor TBitmap_ads.Create(AOwner: TComponent);
begin
ProcName := 'TBitmap_ads.Create'; Try
inherited;
FBitmap := TBitmap.Create();
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

destructor TBitmap_ads.Destroy;
begin
ProcName := 'TBitmap_ads.Destroy'; Try
Try FBitmap.Free; Except End;
inherited;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TBitmap_ads.SetBitmap(const Value: TBitmap);
begin
ProcName := 'TBitmap_ads.SetBitmap'; Try
If FBitmap <> Value Then FBitmap := Value;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Type
TPicture_ads = Class(TComponent)
private
FPicture: TPicture;
procedure SetPicture(const Value: TPicture);
public
Constructor Create(AOwner: TComponent); Override;
Destructor Destroy; Override;
published
property Picture : TPicture read FPicture write SetPicture;
End;

constructor TPicture_ads.Create(AOwner: TComponent);
begin
ProcName := 'TPicture_ads.Create'; Try
inherited;
FPicture := TPicture.Create();
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

destructor TPicture_ads.Destroy;
begin
ProcName := 'TPicture_ads.Destroy'; Try
Try FPicture.Free; Except End;
inherited;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TPicture_ads.SetPicture(const Value: TPicture);
begin
ProcName := 'TPicture_ads.SetPicture'; Try
If FPicture <> Value Then FPicture := Value;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

function ComponentToString(Component: TComponent): string;
var
BinStream:TMemoryStream;
StrStream: TStringStream;
s: string;
begin
ProcName := 'ComponentToString'; Try
BinStream := TMemoryStream.Create;
try
StrStream := TStringStream.Create(s);
try
BinStream.WriteComponent(Component);
BinStream.Seek(0, soFromBeginning);
ObjectBinaryToText(BinStream, StrStream);
StrStream.Seek(0, soFromBeginning);
Result:= StrStream.DataString;
finally
StrStream.Free;
end;
finally
BinStream.Free
end;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

function StringToComponent(Value: string): TComponent;
var
StrStream:TStringStream;
BinStream: TMemoryStream;
begin
Result := nil;
ProcName := 'StringToComponent'; Try
StrStream := TStringStream.Create(Value);
try
BinStream := TMemoryStream.Create;
try
ObjectTextToBinary(StrStream, BinStream);
BinStream.Seek(0, soFromBeginning);
Result := BinStream.ReadComponent(nil);
finally
BinStream.Free;
end;
finally
StrStream.Free;
end;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Function BitmapToString_ads(Bitmap: TBitmap): String;
Var
Bitmap_ads : TBitmap_ads;
Begin
ProcName := 'BitmapToString_ads'; Try
Bitmap_ads := TBitmap_ads.Create(nil);
Try
Bitmap_ads.Bitmap.Assign(Bitmap);
Result := ComponentToString(Bitmap_ads);
Finally
Bitmap_ads.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function StringToBitmap_ads(Bitmap: TBitmap; BitmapString: String): Boolean;
Var
Bitmap_ads : TBitmap_ads;
Image : TBitmap;
Begin
Result := True;
ProcName := 'StringToBitmap_ads'; Try
Try
Bitmap_ads := TBitmap_ads.Create(nil);
Image := TBitmap.Create();
Try
Bitmap_ads := TBitmap_ads(StringToComponent(BitmapString));
Image.Assign(Bitmap_ads.Bitmap);
Bitmap.Assign(Image);
Finally
Bitmap_ads.Free;
Image.Free;
End;
Except
Result := False;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function PictureToString_ads(Picture: TPicture): String;
Var
        Picture_ads : TPicture_ads;
Begin
        ProcName := 'PictureToString_ads';
        Try
                Picture_ads := TPicture_ads.Create(nil);
                Try
                        Picture_ads.Picture.Assign(Picture);
                        Result := ComponentToString(Picture_ads);
                Finally
                        Picture_ads.Free;
                End;
        Except
                On E : Exception Do
                RaiseError(UnitName,ProcName,E);
        End;
End;

Function StringToPicture_ads(Picture: TPicture; PictureString: String): Boolean;
Var
        Picture_ads : TPicture_ads;
        Image : TPicture;
Begin
        Result := True;
        ProcName := 'StringToPicture_ads';
        Try
                Try
                        Picture_ads := TPicture_ads.Create(nil);
                        Image := TPicture.Create();
                        Try
                                Picture_ads := TPicture_ads(StringToComponent(PictureString));
                                Image.Assign(Picture_ads.Picture);
                                Picture.Assign(Image);
                        Finally
                                Picture_ads.Free;
                                Image.Free;
                        End;
                Except
                        Result := False;
                End;
        Except
                On E : Exception Do
                RaiseError(UnitName,ProcName,E);
        End;
End;

Function GlyphToString_ads(Glyph: TBitmap): String;
Begin
ProcName := 'GlyphToString_ads'; Try
Result := BitmapToString_ads(Glyph);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function StringToGlyph_ads(Glyph: TBitmap; GlyphString: String): Boolean;
Begin
Result := False;
ProcName := 'StringToGlyph_ads'; Try
Result := StringToBitmap_ads(Glyph,GlyphString);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function StringToIcon_ads(Icon: TIcon; IconString: String): Boolean;
Var
Icon_ads : TIcon_ads;
Image : TIcon;
Begin
Result := True;
ProcName := 'StringToIcon_ads'; Try
Try
Icon_ads := TIcon_ads.Create(nil);
Image := TIcon.Create();
Try
Icon_ads := TIcon_ads(StringToComponent(IconString));
Image.Assign(Icon_ads.Icon);
Icon.Assign(Image);
Finally
Icon_ads.Free;
Image.Free;
End;
Except
Result := False;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Type
TImageList_ads = Class(TComponent)
private
FImageList: TImageList;
procedure SetImageList(const Value: TImageList);
public
Constructor Create(AOwner: TComponent); Override;
Destructor Destroy; Override;
published
property ImageList : TImageList read FImageList write SetImageList;
End;

constructor TImageList_ads.Create(AOwner: TComponent);
begin
ProcName := 'TImageList_ads.Create'; Try
inherited;
FImageList := TImageList.Create(nil);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

destructor TImageList_ads.Destroy;
begin
ProcName := 'TImageList_ads.Destroy'; Try
Try FImageList.Free; Except End;
inherited;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

procedure TImageList_ads.SetImageList(const Value: TImageList);
begin
ProcName := 'TImageList_ads.SetImageList'; Try
If FImageList <> Value Then FImageList := Value;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;

Function ImageListToString_ads(ImageList: TImageList): String;
Var
ImageList_ads : TImageList_ads;
Begin
ProcName := 'ImageListToString_ads'; Try
ImageList_ads := TImageList_ads.Create(nil);
Try
ImageList_ads.ImageList.Assign(ImageList);
Result := ComponentToString(ImageList_ads);
Finally
ImageList_ads.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Function StringToImageList_ads(Var ImageList: TImageList; ImageListString: String): Boolean;
Var
ImageList_ads : TImageList_ads;
Image : TImageList;
Begin
Result := True;
ProcName := 'StringToImageList_ads'; Try
Try
ImageList_ads := TImageList_ads.Create(nil);
Image := TImageList.Create(nil);
Try
ImageList_ads := TImageList_ads(StringToComponent(ImageListString));
//Image.Assign(ImageList_ads.ImageList);
//ImageList.Assign(Image);
//ImageList := ImageList_ads.ImageList;
//ImageList.Assign(ImageList_ads.ImageList);
ImageList := TImageList(StringToComponent(ImageListString));
Finally
ImageList_ads.Free;
Image.Free;
End;
Except
Result := False;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

Initialization
UnitName := 'ads_GraphicStrings';
ProcName := 'Unknown';
RegisterClasses([TBitmap_ads,TPicture_ads,TIcon_ads,TImageList_ads, TImageList]);
end.



Veri tabanına kayıt ederken :

Kod: Tümünü seç

       Query.Append;
        try QueryMemoAlan.Value:=PictureToString_ads(Image1.Picture); except end;
       Query.Post;
Veri tabanından resmin datasını alırken :

Kod: Tümünü seç

        Image1.Visible:=False;
        Image1.Picture:=Nil;
        If Trim(TasarimlarFon.Value)<>'' Then
        StringToPicture_ads(Image1.Picture, Trim(Query1Memo.Value));
        Image1.Visible:=True;
İstifadenize.. :)
akuyumcu63
Üye
Mesajlar: 386
Kayıt: 02 Tem 2007 09:43

Re: resim ekleme ve okuma

Mesaj gönderen akuyumcu63 »

merhaba;

vermiş olduğunuz kodlar üzerinde bu aralar çalışma imkanı buldum. yaptığım denemelerde ads_Exception unitinde hata mesajı alıyordum. yaptığım araştırmalarda uniti delphi ile alakalı sitelerin birinde buldum şimdi hangisinde bulduğumu hatırlamıyorum. ihtiyaç duyanlar için yayınlayayım dedim.

herkese teşekkür ederim.

Kod: Tümünü seç

unit ads_Exception;

interface

Uses SysUtils, Classes, Windows, FileCtrl;
{
This unit is devoted to exception handling.
If the RaiseError procedure is used throughout an application all
ambiguity is removed as to when and where errors are
occurring.  This procedure can record exactly when, where
and the specific error.  All errors can be logged for
future reference.  Size limits can be set on the log
file and how often the file is written thereby freeing up
memory resources.  The log orders the data newest to oldest
so that the newest errors appear at the beginning.
}

{!~
RaiseError

This procedure is a centralized error handler.

If this procedure is used throughout an application all
ambiguity is removed as to when and where errors are
occurring.  This procedure can record exactly when, where
and the specific error.  All errors can be logged for
future reference.  Size limits can be set on the log
file and how often the file is written thereby freeing up
memory resources.  The log orders the data newest to oldest
so that the newest errors appear at the beginning.

To use this procedure add ads_Exception to a units uses
clause and call RaiseError in functions and procedures where
you desire error handling.

  Example:
    unit MyCodeUnit;
    interface
    Uses
      ads_Exception;

    procedure MyProc;

    Implementation
    const UnitName = MyCodeUnit;

    procedure MyProc;
    Var
      ProcName : String;
    Begin
      ProcName := MyProc'; Try
      .
      .
      .
      Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
    End;

    End.

This procedure handles:
  cleanup prior to handling an error (RaiseErrorInit),
  graceful processing of errors (RaiseErrorHandle),
  logging errors to file (LogErrors True/False),
  raising errors (RaiseErrors True/False),
  post error actions (RaiseErrorLast)

Set the following variables to control the behavior
of the error handling.  The values shown below are the
defaults.
  LogErrors                 := True;
  RaiseErrors               := False;
  ErrorLogSizeLimit         := 1000000;
  SaveToFileEveryNErrors    := 20;
  ErrorLogFileName          := Copy(ParamStr(0),1,Length(ParamStr(0))-4)+'_err_'+UserIDFromWindows+'.txt';
}
Procedure RaiseError(UnitName,ProcName:String;E : Exception);

Var

  {!~
  LogErrors

  Errors are recorded to file, i.e., lofgged based on
  the LogErrors boolean variable.  If True errors are
  written to file, if false error messages are not
  logged.  LogErrors can be used in any
  combination with RasiseErrors to control presentation
  and recording of errors.

    RaiseErrors LogErrors   See Error    Log Error
       TRUE       TRUE         YES          YES
       TRUE       FALSE        YES          NO
       FALSE      TRUE         NO           YES
       FALSE      FALSE        NO           NO }
  LogErrors                 : Boolean;
  {!~
  RaiseErrors

  Errors are presented to users or suppressed based on
  the RaiseErrors boolean variable.  If True errors are
  presented to users, if false error messages are
  suppressed.  RasiseErrors can be used in any
  combination with LogErrors to control presentation
  and recording of errors.

    RaiseErrors LogErrors   See Error    Log Error
       TRUE       TRUE         YES          YES
       TRUE       FALSE        YES          NO
       FALSE      TRUE         NO           YES
       FALSE      FALSE        NO           NO }
  RaiseErrors               : Boolean;
  {!~
  ErrorLogFileName

  If LogErrors is set to True then all unhandled errors
  are logged to a file. The log file path and name are
  set by ErrorLogFileName.  The default value for
  ErrorLogFileName is

    ExecutableName+'_err_'+UserIDFromWindows+'.txt'.

  This default naming allows for an executable to be run
  from the network and each user has his own error log.
  The filename can be changed at runtime.}
  ErrorLogFileName          : String;
  {!~
  RaiseErrorInit

  This procedure is run first in the RaiseError procedure.
  This procedure provides an opportunity to do cleanup
  before processing an error.  An example of cleanup
  would be correcting the mouse cursor.
  }
  RaiseErrorInit            : Procedure;
  {!~
  RaiseErrorHandle

  This procedure is run after RaiseErrorInit in the RaiseError
  procedure.

  If the RaiseErrorHandle function returns True meaning that
  the error has been successfully handled, then the error is
  not raised or logged, otherwise flow continues in the
  RaiseError procedure to log and raise the error as appropriate.
  The RaiseErrorHandle procedure is a place to handle errors.
  Procedures can be assigned to RaiseErrorHandle on the fly
  like: RaiseErrorHandle := MyErrorHandler;

  To disable a current setting for RaiseErrorHandle set this
  variable to nil.
  }
  RaiseErrorHandle          : Function(UnitName,ProcName:String;E : Exception): Boolean;
  {!~
  RaiseErrorLast

  This procedure is run last in the RaiseError procedure.
  }
  RaiseErrorLast            : Procedure;
  {!~
  ErrorLogSizeLimit

  This variable establishes the upper limit on the size of the
  log file.  If LogErrors = True then errors are recorded in
  ErrorLogFileName.  If the size of the log file reaches
  the value set by ErrorLogSizeLimit then the file is reduced
  in size until it reaches the size limit.  Error messages
  are deleted from the oldest to the newest.  The default
  value for ErrorLogSizeLimit is 1000000.  Please remember
  this variable is of type Int64 not Integer.  There is a
  difference.
  }
  ErrorLogSizeLimit         : Int64;
  {!~
  SaveToFileEveryNErrors

  This variable establishes how frequently the error data
  in memory is written to file.  The default is 20, meaning
  that after 20 errors the log in memory is written to file
  and then the memory log is cleared.  This allows the
  maximum amount of memory to be available to the application
  and solves a problem where a user keeps an application open
  all day and the log keeps on getting bigger and bigger
  thereby draining memory resources.

  Setting SaveToFileEveryNErrors to 20 ensures that never
  will the memory log be any bigger than 20 errors.}
  SaveToFileEveryNErrors    : Integer;

implementation

Const UnitName              = 'ads_Exception';
Var
  ErrorLog                  : TStringList;
  ProcName                  : String;

Function UserIDFromWindows: string;
Var
  UserName    : string;
  UserNameLen : Dword;
Begin
  UserNameLen := 255;
  SetLength(userName, UserNameLen);
  If GetUserName(PChar(UserName), UserNameLen) Then
    Result := Copy(UserName,1,UserNameLen - 1)
  Else
    Result := 'Unknown';
End;

function GetFileSize(const FileName: string): LongInt;
Var
  SearchRec: TSearchRec;
  sgPath   : String;
  inRetval : Integer;
begin
  sgPath   := ExpandFileName(FileName);
  Try
    inRetval := FindFirst(ExpandFileName(FileName), faAnyFile, SearchRec);
    If inRetval = 0 Then
      Result := SearchRec.Size
    Else Result := -1;
  Finally
    SysUtils.FindClose(SearchRec);
  End;
end;

{!~
TrimErrorLog

This routine controls the saving and sizing of the error log.
}
Procedure TrimErrorLog(lst : TStringList);
Var
  inCounter : Integer;
  ProcName  : String;
  boBreak   : Boolean;
begin
  ProcName  := 'TrimErrorLog'; Try
  boBreak   := False;
  inCounter := 1;
  lst.SaveToFile(ErrorLogFileName);
  While True Do
  Begin
    If FileExists(ErrorLogFileName) Then
    Begin
      If GetFileSize(ErrorLogFileName) > ErrorLogSizeLimit Then
      Begin
        lst.Delete(lst.Count-1);
        lst.SaveToFile(ErrorLogFileName);
      End
      Else
      Begin
        boBreak := True;
      End;
    End
    Else
    Begin
      Break;
    End;
    inc(inCounter);
    If boBreak          Then Break;
    If inCounter > 1000 Then Break;
    If lst.Count < 10   Then Break;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

{!~
SaveErrorLog

This routine controls the saving and sizing of the error log.
}
Procedure SaveErrorLog;
Var
  lst       : TStringList;
  inCounter : Integer;
  ProcName  : String;
  sgPath    : String;
begin
  ProcName := 'SaveErrorLog'; Try
  lst := TStringList.create();
  Try
    sgPath := ExtractFilePath(ErrorLogFileName);
    If Not DirectoryExists(sgPath) Then ForceDirectories(sgPath);
    lst.Clear;
    If FileExists(ErrorLogFileName) Then
      lst.LoadFromFile(ErrorLogFileName);
    ErrorLog.SetText(PChar(ErrorLog.Text+lst.Text));
    ErrorLog.Sorted := True;
    ErrorLog.Sorted := False;
    lst.Clear;
    For inCounter := (ErrorLog.Count - 1) DownTo 0 Do
    Begin
      lst.Add(ErrorLog[inCounter]);
    End;
    TrimErrorLog(lst);
  Finally
    lst.Free;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;

{!~
RaiseError

This procedure is a centralized error handler.

If this procedure is used throughout an application all
ambiguity is removed as to when and where errors are
occurring.  This procedure can record exactly when, where
and the specific error.  All errors can be logged for
future reference.  Size limits can be set on the log
file and how often the file is written thereby freeing up
memory resources.  The log orders the data newest to oldest
so that the newest errors appear at the beginning.

To use this procedure add ads_Exception to a units uses
clause and call RaiseError in functions and procedures where
you desire error handling.

  Example:
    unit MyCodeUnit;
    interface
    Uses
      ads_Exception;

    procedure MyProc;

    Implementation
    const UnitName = MyCodeUnit;

    procedure MyProc;
    Var
      ProcName : String;
    Begin
      ProcName := MyProc'; Try
      .
      .
      .
      Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
    End;

    End.

This procedure handles:
  cleanup prior to handling an error (RaiseErrorInit),
  graceful processing of errors (RaiseErrorHandle),
  logging errors to file (LogErrors True/False),
  raising errors (RaiseErrors True/False),
  post error actions (RaiseErrorLast)

Set the following variables to control the behavior
of the error handling.  The values shown below are the
defaults.
  LogErrors                 := True;
  RaiseErrors               := False;
  ErrorLogSizeLimit         := 1000000;
  SaveToFileEveryNErrors    := 20;
  ErrorLogFileName          := Copy(ParamStr(0),1,Length(ParamStr(0))-4)+'_err_'+UserIDFromWindows+'.txt';
}
Procedure RaiseError(UnitName,ProcName:String;E : Exception);
Var
  sgErr          : String;
  boHandled      : Boolean;
Begin
  If Assigned(RaiseErrorInit)   Then RaiseErrorInit;
  If Assigned(RaiseErrorHandle) Then
  Begin
    boHandled := RaiseErrorHandle(UnitName,ProcName,E);
    If boHandled Then Exit;
  End;
  If LogErrors Then
  Begin
    sgErr := E.Message;
    sgErr := StringReplace(sgErr,#13,'',[rfReplaceall]);
    sgErr := StringReplace(sgErr,#10,'',[rfReplaceall]);
    ErrorLog.Add(FormatDateTime('yyyymmddhhnnss',now())+' '+UnitName+'.'+Procname+' error: '+sgErr);
    If ErrorLog.Count > SaveToFileEveryNErrors Then
    Begin
      SaveErrorLog;
      ErrorLog.Clear;
    End;
  End;
  If RaiseErrors     Then Raise Exception.Create(UnitName+'.'+Procname+' error: '+sgErr);
  If Assigned(RaiseErrorLast) Then RaiseErrorLast;
End;

Initialization
  ProcName                  := 'Initialization'; Try
  LogErrors                 := True;
  RaiseErrors               := False;
  ErrorLogSizeLimit         := 1000000;
  SaveToFileEveryNErrors    := 20;
  ErrorLogFileName          := Copy(ParamStr(0),1,Length(ParamStr(0))-4)+'_err_'+UserIDFromWindows+'.txt';
  ErrorLog                  := TstringList.Create();
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
Finalization
  ProcName := 'Finalization'; Try
  If LogErrors Then SaveErrorLog;
  ErrorLog        .Free; ErrorLog        := nil;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End.
İsteyen, yapabildiğinden daha fazlasını yapar.
Cevapla