Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС
выпущен 4 ноября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Конвертируем таблицу в Excel c использованием TExcelApplication


 // Переписываем
 
 TabGrid := VarArrayCreate([0,(R - 1),0,(C - 1)],VarVariant);
 ...
 TabGrid[I,J] := FieldToVariant(dbGrid.Columns.Items[J].Field);
 
 // И пишем функцию:
 
 function FieldToVariant(Field:TField):OLEVariant;
 begin
     Result := '';
     case Field.DataType of
          ftString, ftFixedChar, ftWideString, ftMemo,
          ftFmtMemo: Result := '''' + Field.AsString;
          ftSmallint, ftInteger, ftWord, ftLargeint, ftAutoInc:
                     Result := Field.AsInteger;
          ftFloat, ftCurrency, ftBCD: Result := Field.AsFloat;
          ftBoolean: Result := Field.AsBoolean;
          ftDate, ftTime, ftDateTime: Result := Field.AsDateTime;
     end
 end;
 




Координаты курсора в Memo


Тяжело сгонять муху курсором с монитора.


 var
   X, Y: LongInt;
 begin
   Y := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);
   X := Memo1.Perform(EM_LINEINDEX, Y, 0);
   inc(Y);
   X := Memo1.SelStart - X + 1;
   Form1.Caption := 'X = ' + IntToStr(X) + ' : ' + 'Y = ' + IntToStr(Y);
 end;
 




Координаты курсора в Memo 2


 procedure CaretPos(H: THandle; var L, C: Word);
 begin
   L := SendMessage(H, EM_LINEFROMCHAR, -1, 0);
   C := LoWord(SendMessage(H, EM_GETSEL, 0, 0)) -
     SendMessage(H, EM_LINEINDEX, -1, 0);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   LineNum, ColNum: Word;
 begin
   CaretPos(Memo1.Handle, LineNum, ColNum);
   Edit1.Text := IntToStr(LineNum) + '  ' + IntToStr(ColNum);
 end;
 

Хотя в Delphi 5 свойство CaretPos уже включено в memo.




Как поместить прозрачную фоновую картинку на компонент CoolBar


 procedure TForm1.Button1Click(Sender: TObject);
 var
  Bm1 : TBitmap;
  Bm2 : TBitmap;
 begin
  Bm1 := TBitmap.Create;
  Bm2 := TBitmap.Create;
  Bm1.LoadFromFile('c:\download\test.bmp');
  Bm2.Width := Bm1.Width;
  Bm2.Height := Bm1.Height;
  bm2.Canvas.Brush.Color := CoolBar1.Color;
  bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
    Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
  bm1.Free;
  CoolBar1.Bitmap.Assign(bm2);
  bm2.Free;
 end;
 




Скопировать все файлы вместе с подкаталогами




 procedure TForm1.Button1Click(Sender: TObject);
 var
   OpStruc: TSHFileOpStruct;
   frombuf, tobuf: array [0..128] of Char;
 begin
   FillChar( frombuf, Sizeof(frombuf), 0 );
   FillChar( tobuf, Sizeof(tobuf), 0 );
   StrPCopy( frombuf, 'c:\1\*.*' );
   StrPCopy( tobuf, 'c:\2' );
   with OpStruc do
   begin
     Wnd:= Handle;
     wFunc:= FO_COPY;
     pFrom:= @frombuf;
     pTo:=@tobuf;
     fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
     fAnyOperationsAborted:= False;
     hNameMappings:= nil;
     lpszProgressTitle:= nil;
   end;
   ShFileOperation( OpStruc );
 end;
 




Скопировать, удалить, вставить в TWebBrowser


 uses
  ActiveX;
 
 // Copy the selected text to the clipboard 
 procedure TForm1.Button7Click(Sender: TObject);
 begin
   try
     WebBrowser1.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER);
   except
   end;
 end;
 
 // Cut the selected text 
 procedure TForm1.Button8Click(Sender: TObject);
 begin
   try
     WebBrowser1.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_PROMPTUSER);
   except
   end;
 end;
 
 // Delete the selected text 
 procedure TForm1.Button9Click(Sender: TObject);
 begin
   try
     WebBrowser1.ExecWB(OLECMDID_DELETE, OLECMDEXECOPT_PROMPTUSER);
   except
   end;
 end;
 
 
 initialization
   OleInitialize(nil);
 
 finalization
   OleUninitialize;
 end.
 
 // as of Internet Explorer 4
 




Скопировать, удалить, переместить всю директорию


 uses
   ShellApi;
 
 function CopyDir(const fromDir, toDir: string): Boolean;
 var
   fos: TSHFileOpStruct;
 begin
   ZeroMemory(@fos, SizeOf(fos));
   with fos do
   begin
     wFunc  := FO_COPY;
     fFlags := FOF_FILESONLY;
     pFrom  := PChar(fromDir + #0);
     pTo    := PChar(toDir)
   end;
   Result := (0 = ShFileOperation(fos));
 end;
 
 
 function MoveDir(const fromDir, toDir: string): Boolean;
 var
   fos: TSHFileOpStruct;
 begin
   ZeroMemory(@fos, SizeOf(fos));
   with fos do
   begin
     wFunc  := FO_MOVE;
     fFlags := FOF_FILESONLY;
     pFrom  := PChar(fromDir + #0);
     pTo    := PChar(toDir)
   end;
   Result := (0 = ShFileOperation(fos));
 end;
 
 function DelDir(dir: string): Boolean;
 var
   fos: TSHFileOpStruct;
 begin
   ZeroMemory(@fos, SizeOf(fos));
   with fos do
   begin
     wFunc  := FO_DELETE;
     fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
     pFrom  := PChar(dir + #0);
   end;
   Result := (0 = ShFileOperation(fos));
 end;
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if cCopyDir('d:\download', 'e:\') = True then
     ShowMessage('Directory copied.');
 end;
 




Как скопировать директорию с файлами


 unit FilesOp;
 
 interface
 
 uses Forms, SysUtils, ShellAPI, Dialogs;
 
 procedure CopyFiles(const FromFolder: string; const ToFolder: string);
 
 implementation
 
 procedure CopyFiles(const FromFolder: string; const ToFolder: string);
 var
   Fo      : TSHFileOpStruct;
   buffer  : array[0..4096] of char;
   p       : pchar;
 begin
   FillChar(Buffer, sizeof(Buffer), #0);
   p := @buffer;
   StrECopy(p, PChar(FromFolder)); //директория, которую мы хотим скопировать
   FillChar(Fo, sizeof(Fo), #0);
   Fo.Wnd    := Application.Handle;
   Fo.wFunc  := FO_COPY;
   Fo.pFrom  := @Buffer;
   Fo.pTo    := PChar(ToFolder); //куда будет скопирована директория
   Fo.fFlags := 0;
   if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then
     ShowMessage('File copy process cancelled')
 end;
 
 end.
 




Копирование файлов

F8 - Copy? Да кто ж тебе это сказал?!

Копирование методом TurboPascal


 type
   {Для индикации процесса копирования}
   TCallBack = procedure (Position, Size: Longint);
 
 procedure FastFileCopy(const InfileName, OutFileName: string;
           CallBack: TCallBack);
 const
   BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат }
 type
   PBuffer = ^TBuffer;
   TBuffer = array [1..BufSize] of Byte;
 var
   Size : integer;
   Buffer : PBuffer;
   infile, outfile : file;
   SizeDone, SizeFile: Longint;
 begin
   if (InFileName <> OutFileName) then
   begin
     buffer := nil;
     AssignFile(infile, InFileName);
     System.Reset(infile, 1);
     try
       SizeFile := FileSize(infile);
       AssignFile(outfile, OutFileName);
       System.Rewrite(outfile, 1);
       try
         SizeDone := 0; New(Buffer);
         repeat
           BlockRead(infile, Buffer^, BufSize, Size);
           Inc(SizeDone, Size);
           CallBack(SizeDone, SizeFile);
           BlockWrite(outfile,Buffer^, Size)
         until
           Size < BufSize;
         FileSetDate(TFileRec(outfile).Handle,
         FileGetDate(TFileRec(infile).Handle));
       finally
         if Buffer <> nil then
           Dispose(Buffer);
         System.close(outfile)
       end;
     finally
       System.close(infile);
     end;
   end
   else
     raise EInOutError.Create('File cannot be copied into itself');
 end;
 

Копирование методом потока


 procedure FileCopy(const SourceFileName, TargetFileName: string);
 var
   S, T : TFileStream;
 begin
   S := TFileStream.Create(sourcefilename, fmOpenRead );
   try
     T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
     try
       T.CopyFrom(S, S.Size ) ;
       FileSetDate(T.Handle, FileGetDate(S.Handle));
     finally
       T.Free;
     end;
   finally
     S.Free;
   end;
 end;
 

Копирование методом LZExpand


 uses
   LZExpand;
 
 procedure CopyFile(FromFileName, ToFileName : string);
 var
   FromFile, ToFile: file;
 begin
   AssignFile(FromFile, FromFileName);
   AssignFile(ToFile, ToFileName);
   Reset(FromFile);
   try
     Rewrite(ToFile);
     try
       if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle)<0 then
         raise Exception.Create('Error using LZCopy')
     finally
       CloseFile(ToFile);
     end;
   finally
     CloseFile(FromFile);
   end;
 end;
 

Копирование методами Windows


 uses
   // !!! важно
   ShellApi;
 
 function WindowsCopyFile(FromFile, ToDir : string) : boolean;
 var
   F: TShFileOpStruct;
 begin
   F.Wnd := 0; F.wFunc := FO_COPY;
   FromFile:=FromFile+#0; F.pFrom:=pchar(FromFile);
   ToDir:=ToDir+#0; F.pTo:=pchar(ToDir);
   F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
   result:=ShFileOperation(F) = 0;
 end;
 
 // пример копирования
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then
     ShowMessage('Copy Failed');
 end;
 




Функция, которая устанавливает дату одного файла, равную дате другого файла


 procedure CopyFileDate(const Source, Dest: String);
 var
   SourceHand, DestHand: word;
 begin
   SourceHand := FileOpen(Source, fmOutput);       { открываем исходный файл }
   DestHand := FileOpen(Dest, fmInput);            { открываем целевой файл }
   FileSetDate(DestHand, FileGetDate(SourceHand)); { получаем/устанавливаем дату }
   FileClose(SourceHand);                          { закрываем исходный файл }
   FileClose(DestHand);                            { закрываем целевой файл }
 end;
 




Копируем файл в буфер обмена


 uses
   ShlObj, ClipBrd;
 
 procedure CopyFilesToClipboard(FileList: string);
 var
   DropFiles: PDropFiles;
   hGlobal: THandle;
   iLen: Integer;
 begin
   iLen := Length(FileList) + 2;
   FileList := FileList + #0#0;
   hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,
     SizeOf(TDropFiles) + iLen);
   if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');
   begin
     DropFiles := GlobalLock(hGlobal);
     DropFiles^.pFiles := SizeOf(TDropFiles);
     Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);
     GlobalUnlock(hGlobal);
     Clipboard.SetAsHandle(CF_HDROP, hGlobal);
   end;
 end;
 
 // Example, Beispiel: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat');
 end;
 
 //Separate the files with a #0.
 




Копируем файл с индикатором процесса


 { 1. }
 
 {
  You need a TProgressBar on your form for this tip.
  Fьr diesen Tip wird eine TProgressBar benцtigt.
 }
 
 
 procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
 var
   FromF, ToF: file of byte;
   Buffer: array[0..4096] of char;
   NumRead: integer;
   FileLength: longint;
 begin
   AssignFile(FromF, Source);
   reset(FromF);
   AssignFile(ToF, Destination);
   rewrite(ToF);
   FileLength := FileSize(FromF);
   with Progressbar1 do
   begin
     Min := 0;
     Max := FileLength;
     while FileLength > 0 do
     begin
       BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
       FileLength := FileLength - NumRead;
       BlockWrite(ToF, Buffer[0], NumRead);
       Position := Position + NumRead;
     end;
     CloseFile(FromF);
     CloseFile(ToF);
   end;
 end;
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   CopyFileWithProgressBar1('c:\Windows\Welcome.exe', 'c:\temp\Welcome.exe');
 end;
 
 { 2. }
 
 {***************************************}
 
 // To show the estimated time to copy a file: 
 
 procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
 var
   FromF, ToF: file of byte;
   Buffer: array[0..4096] of char;
   NumRead: integer;
   FileLength: longint;
   t1, t2: DWORD;
   maxi: integer;
 begin
   AssignFile(FromF, Source);
   reset(FromF);
   AssignFile(ToF, Destination);
   rewrite(ToF);
   FileLength := FileSize(FromF);
   with Progressbar1 do
   begin
     Min  := 0;
     Max  := FileLength;
     t1   := TimeGetTime;
     maxi := Max div 4096;
     while FileLength > 0 do
     begin
       BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
       FileLength := FileLength - NumRead;
       BlockWrite(ToF, Buffer[0], NumRead);
       t2  := TimeGetTime;
       Min := Min + 1;
       // Show the time in Label1 
       label1.Caption := FormatFloat('0.00', ((t2 - t1) / min * maxi - t2 + t1) / 100);
       Application.ProcessMessages;
       Position := Position + NumRead;
     end;
     CloseFile(FromF);
     CloseFile(ToF);
   end;
 end;
 
 { 3. }
 {***************************************}
 // To show the estimated time to copy a file, using a callback function: 
 
 type
   TCallBack = procedure(Position, Size: Longint); { export; }
 
 procedure FastFileCopy(const InFileName, OutFileName: string;
   CallBack: TCallBack);
 
 
 implementation
 
 procedure FastFileCopyCallBack(Position, Size: Longint);
 begin
   Form1.ProgressBar1.Max := Size;
   Form1.ProgressBar1.Position := Position;
 end;
 
 procedure FastFileCopy(const InFileName, OutFileName: string;
   CallBack: TCallBack);
 const
   BufSize = 3 * 4 * 4096; { 48Kbytes gives me the best results }
 type
   PBuffer = ^TBuffer;
   TBuffer = array[1..BufSize] of Byte;
 var
   Size: DWORD;
   Buffer: PBuffer;
   infile, outfile: file;
   SizeDone, SizeFile: LongInt;
 begin
   if (InFileName <> OutFileName) then
   begin
     buffer := nil;
     Assign(infile, InFileName);
     Reset(infile, 1);
     try
       SizeFile := FileSize(infile);
       Assign(outfile, OutFileName);
       Rewrite(outfile, 1);
       try
         SizeDone := 0;
         New(Buffer);
         repeat
           BlockRead(infile, Buffer^, BufSize, Size);
           Inc(SizeDone, Size);
           CallBack(SizeDone, SizeFile);
           BlockWrite(outfile, Buffer^, Size)
         until Size < BufSize;
         FileSetDate(TFileRec(outfile).Handle,
         FileGetDate(TFileRec(infile).Handle));
       finally
         if Buffer <> nil then
           Dispose(Buffer);
         CloseFile(outfile)
       end;
     finally
       CloseFile(infile);
     end;
   end
   else
     raise EInOutError.Create('File cannot be copied onto itself')
 end; {FastFileCopy}
 
 
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   FastFileCopy('c:\daten.txt', 'c:\test\daten2.txt', @FastFileCopyCallBack);
 end;
 
 { 4. }
 {***************************************}
 
 
 function CopyFileWithProgressBar2(TotalFileSize,
   TotalBytesTransferred,
   StreamSize,
   StreamBytesTransferred: LARGE_INTEGER;
   dwStreamNumber,
   dwCallbackReason: DWORD;
   hSourceFile,
   hDestinationFile: THandle;
   lpData: Pointer): DWORD; stdcall;
 begin
   // just set size at the beginning 
   if dwCallbackReason = CALLBACK_STREAM_SWITCH then
     TProgressBar(lpData).Max := TotalFileSize.QuadPart;
 
   TProgressBar(lpData).Position := TotalBytesTransferred.QuadPart;
   Application.ProcessMessages;
   Result := PROGRESS_CONTINUE;
 end;
 
 function TForm1.CopyWithProgress(sSource, sDest: string): Boolean;
 begin
   // set this FCancelled to true, if you want to cancel the copy operation 
   FCancelled := False;
   Result     := CopyFileEx(PChar(sSource), PChar(sDest), @CopyFileWithProgressBar2,
     ProgressBar1, @FCancelled, 0);
 end;
 
 end;
 




Как скопировать картинку в буфер обмена

Программист после очень длительного сидения за компьютером выходит на улицу и смотрит на небо: "Боже, у Тебя тоже Windows стоит?!"


 Clipboard.Assign(Image1.Picture);
 




Копировать и вставлять TreeNode


  var
    SL : TStringList;
 
  procedure TForm1.CutBtnClick(Sender: TObject);
  var
    i, j, StartLevel : integer;
    TNSel : TTreeNode;
  begin
    TNSel := TreeView1.Selected;
    if TNSel <> nil then begin
      StartLevel := TNSel.Level;
      i := TNSel.AbsoluteIndex;
      j := i; // note for later deletion
      if SL = nil then
        SL := TStringList.Create
      else
        SL.Clear;
      SL.AddObject(TNSel.Text, pointer(0));
      inc(i);
      with TreeView1 do begin
        while Items[i].Level > StartLevel do begin
          {stop before next sibling to top node\}
          SL.AddObject(Items[i].Text, pointer(Items[i].Level - StartLevel));
          inc(i);
        end; {while Items[i].Level > StartLevel\}
        Items[j].Delete;
      end; {with TreeView1\}
    end; {if TNSel <> nil\}
  end;
 
  procedure TForm1.PasteBtnClick(Sender: TObject);
  var
    i, Level : integer;
    TNSel, TN : TTreeNode;
  begin
    with TreeView1 do begin
      TNSel := Selected;
      if TNSel <> nil then begin
        TN := Items.Insert(TNSel, SL.Strings[0]);
        Level := integer(SL.Objects[0]); // should be 0
        for i := 1 to SL.Count - 1 do begin
          if integer(SL.Objects[i]) < Level then begin
            {go up one level\}
            TN := TN.Parent;
            Level := integer(SL.Objects[i]);
          end; {if integer(SL.Objects[i]) < Level\}
          if Level = integer(SL.Objects[i]) then
            {same level\}
            TN := Items.Add(TN, SL.Strings[i])
          else begin
            {go down one level\}
            TN := Items.AddChild(TN, SL.Strings[i]);
            Level := integer(SL.Objects[i]);
          end; {if Level = integer(SL.Objects[i])\}
        end; {for i := 1 to SL.Count - 1\}
      end; {if TNSel <> nil\}
    end; {with TreeView1\}
  end;
 




Копирование записи в пределах одной и той же таблицы

Автор: OAmiry (Borland)

"Каким образом мне копировать запись в пределах одного и того же TTable? То есть, если я вижу текущую запись на экране и хочу ее скопировать в ту же таблицу с изменением индекса поля(ей), то какие действия мне необходимо предпринять?"

Необходимы два TTable, связанные с одной таблицей. Когда Table1 позиционируется в копируемой строке, с помощью Table2 вы можете выполнить операцию добавления записи. Пример: {только для демонстрации идеи, пример может быть нерабочим}


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: Cardinal;
   srcStream: TBlobStream;
 begin
   try
     with Table1 do
     begin
       CheckBrowseMode;
       if EOF or BOF then
         raise Exception.Create('Разместите курсор на правильной строке');
     end;
     with Table2 do
     begin
       Append;
       for i := 0 to Table1.FieldCount - 1 do
         if Table1.Fields[i].DataType < ftBytes then
           FieldByName(Table1.Fields[i].FieldName).Assign(Table1.Fields[i])
         else
         try
           srcStream := nil;
           srcStream := TBlobStream.Create(TBlobField(Table1.Fields[i]), bmRead);
           TBlobField(FieldByName(Table1.Fields[i].FieldName)).LoadFromStream(srcStream);
         finally
           if Assigned(srcStream) then
             srcStream.Free;
         end;
       Post;
     end;
   except
     on E: EDBEngineError do
       MessageDlg(E.Message, mtError, [mbOk], 0);
     on E: Exception do
       MessageDlg(E.Message, mtError, [mbOk], 0);
   end;
 end;
 




Копирование записи из одной таблицы в другую

Автор: Josh


 procedure TTableRecordCopy(Source, Destination: TTable);
 {ПРЕДПОЛОЖЕНИЕ: Обе таблицы имеют курсор в нужной строке и
 компоненты Table ссылаются на таблицы с совместимыми величинами.}
 var
   i, lCount: Integer;
 begin
   lCount := Source.FieldCount;
   for i := 0 to lCount - 1 do
     if (not Source.Fields[i].IsNull) and (Source.Fields[i].CanModify) then
       Destination.FieldByName(Source.Fields[i].FieldName).Assign(Source.Fields[i]);
 end;
 

Это работает для всех типов полей.




Копирование экрана


Новая марка монохромных мониторов ViewSonic имеет в качестве символа трех пингвинов.


 unit ScrnCap;
 
 interface
 
 uses
   WinTypes, WinProcs, Forms, Classes, Graphics, Controls;
 
 { Копирует прямоугольную область экрана }
 function CaptureScreenRect(ARect : TRect) : TBitmap;
 { Копирование всего экрана }
 function CaptureScreen : TBitmap;
 { Копирование клиентской области формы или элемента }
 function CaptureClientImage(Control : TControl) : TBitmap;
 { Копирование всей формы элемента }
 function CaptureControlImage(Control : TControl) : TBitmap;
 
 implementation
 
 function GetSystemPalette : HPalette;
 var
   PaletteSize : integer;
   LogSize : integer;
   LogPalette : PLogPalette;
   DC : HDC;
   Focus : HWND;
 begin
   result:=0;
   Focus:=GetFocus;
   DC:=GetDC(Focus);
   try
     PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
     LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
     GetMem(LogPalette, LogSize);
     try
       with LogPalette^ do
       begin
         palVersion:=$0300;
         palNumEntries:=PaletteSize;
         GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
       end;
       result:=CreatePalette(LogPalette^);
     finally
       FreeMem(LogPalette, LogSize);
     end;
   finally
     ReleaseDC(Focus, DC);
   end;
 end;
 
 
 function CaptureScreenRect(ARect : TRect) : TBitmap;
 var
   ScreenDC : HDC;
 begin
   Result:=TBitmap.Create;
   with result, ARect do
   begin
     Width:=Right-Left;
     Height:=Bottom-Top;
     ScreenDC:=GetDC(0);
     try
       BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
     finally
       ReleaseDC(0, ScreenDC);
     end;
     Palette:=GetSystemPalette;
   end;
 end;
 
 function CaptureScreen : TBitmap;
 begin
   with Screen do
     Result:=CaptureScreenRect(Rect(0,0,Width,Height));
 end;
 
 function CaptureClientImage(Control : TControl) : TBitmap;
 begin
   with Control, Control.ClientOrigin do
     result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
 end;
 
 function CaptureControlImage(Control : TControl) : TBitmap;
 begin
   with Control do
     if Parent=nil then
       result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
     else
       with Parent.ClientToScreen(Point(Left, Top)) do
         result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
 end;
 
 end.
 




Копирование экрана 2


 // Для копирования изображения, находящегося в клиентской части
 // формы есть метод GetFormImage. Для копирования любого
 // прямоугольника экрана можно воспользоваться функциями GDI.
 
 // Копирование произвольной прямоугольной области экрана
 Function CaptureScreenRect( ARect: TRect ): TBitmap;
 var
   ScreenDC: HDC;
 begin
   Result := TBitmap.Create;
   with Result, ARect do
   begin
     Width := Right - Left;
     Height := Bottom - Top;
 
     // получаем для экрана контекст устройства
     ScreenDC := GetDC( 0 );
     try
       // копируем оттуда прямоугольную область на канву
       // растрового изображения
       BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC,
         Left, Top, SRCCOPY );
     finally
       ReleaseDC( 0, ScreenDC );
     end;
   end;
 end;
 
 // Таким образом, задавая нужный прямоугольник, можно получить
 // изображение любой части экрана, получить изображение любого
 // элемента формы(кнопок , выпадающих списков и так далее).
 
 // Пример для копирования нужного элемента формы или всей формы,
 // включая и заголовок и рамку:
 Function CaptureControlImage( Control: TControl ): TBitmap;
 begin
   with Control do
     IF Parent = nil Then
       Result := CaptureScreenRect( Bounds( Left, Top, Width,Height ))
     Else
     With Parent.ClientToScreen( Point( Left, Top )) DO
       Result := CaptureScreenRect( Bounds( X, Y, Width,Height ));
 end;
 
 




Копирование содержимого экрана на форму


 var
   Image3: TImage;
 
 procedure TSaverForm.CopyScreen;
 var
 
   DeskTopDC: HDc;
   DeskTopCanvas: TCanvas;
   DeskTopRect: TRect;
 begin
 
   Image3 := TImage.Create(SaverForm);
   with Image3 do
   begin
     Height := Screen.Height;
     Width := Screen.Width;
   end;
   Image3.Canvas.copymode := cmSrcCopy;
   DeskTopDC := GetWindowDC(GetDeskTopWindow);
   DeskTopCanvas := TCanvas.Create;
   DeskTopCanvas.Handle := DeskTopDC;
   Image3.Canvas.CopyRect(Image3.Canvas.ClipRect, DeskTopCanvas,
     DeskTopCanvas.ClipRect);
   Image2.Picture.Assign(Image3.Picture);
   {image2 расположен на целевой форме и выровнен по области клиента}
 end;
 
 procedure TSaverForm.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
 
   Image3.Free;
 end;
 

В настоящее время я также разбираюсь в других ответах на мой вопрос.

Попробуйте следующий HAX 244, взятый из Авг/Сен номера журнала Visual Developer. Это работает, и работает хорошо.


 { смотри текстовое описание за последним END. }
 unit Scrncap;
 
 interface
 uses WinTypes, WinProcs, Forms, Classes, Graphics;
 
 function CaptureScreenRect(ARect: TRect): TBitmap;
 function CaptureScreen: TBitmap;
 function CaptureClientImage(Control: TControl): TBitmap;
 function CaptureControlImage(Control: TControl): TBitmap;
 
 implementation
 
 { используем следующий код для захвата прямоугольной области экрана }
 
 function CaptureScreenRect(ARect: TRect): TBitmap;
 var
   ScreenDC: HDC;
 begin
 
   Result := TBitmap.Create;
   with Result, ARect do
   begin
     Width := Right - Left;
     Height := Bottom - Top;
 
     ScreenDC := GetDC(0);
     try
       BitBlt(Canvas.Handle, 0, 0, Width, Height,
         ScreenDC, Left, Top, SRCCOPY);
     finally
       ReleaseDC(0, ScreenDC);
     end;
   end;
 end;
 
 { используем следующий код для захвата целого экрана }
 
 function CaptureScreen: TBitmap;
 begin
 
   with Screen do
     Result := CaptureScreenRect(Rect(0, 0, Width, Height));
 end;
 
 { используем следующий код для захвата клиентской области
 формы или элемента управления...}
 
 function CaptureClientImage(Control: TControl): TBitmap;
 begin
 
   with Control, Control.ClientOrigin do
     Result := CaptureScreenRect(Bounds(X, Y, ClientWidth,
 
       ClientHeight));
 end;
 
 { используйте следующий код для захвата целой формы
 или элемента управления  }
 
 function CaptureControlImage(Control: TControl): TBitmap;
 begin
 
   with Control do
     if Parent = nil then
       Result := CaptureScreenRect(Bounds(Left, Top, Width,
         Height))
     else
       with Parent.ClientToScreen(Point(Left, Top)) do
         Result := CaptureScreenRect(Bounds(X, Y, Width, Height));
 end;
 
 end.
 
 {
 Источник:  Visual Developer, HAX #244, Авг/Сент 1996
 
 захват экрана с помощью Delphi
 
 В Delphi, если вы хотите получить изображение клиентской области формы,
 необходимо вызвать GetFormlmage. Но иногда возникает необходимость
 получения снимка формы целиком, вместе с заголовком, контуром и всем
 содержимым. Или целиком всего экрана. Если бы у вас был дефицит времени,
 мы бы в этом случае посоветовали показывать диалоговое окно с надписью
 "Теперь нажмите кнопку Print Screen!", после чего работать с
 изображением, помещенным в буфер обмена.
 
 Но мы никуда не спешим. Комбинирование хостов Delphi с несколькими
 функциями GDI сводят задачу получения снимка экрана всего к одной
 строчке кода.
 
 CaptureScreenRect, в листинге 1, демонстрирует это. Код получает
 экранный контекст устройства с помощью GetDC(O), и затем копирует
 прямоугольную область этого DC на холст изображения (Bitmap). Для
 копирования используется BitBlt. Смысл использования BitBlt (и
 любой функции GDI) в том, что Delphi помнит, что дескриптор холста
 есть DC, необходимый Windows.
 
 Остальные функции копирования экрана в листинге 1 захватывают
 прямоугольник и отдает реальную работу на откуп CaptureScreenRect.
 CaptureScreen захватывает для прямоугольника целый экран.
 CaptureClientImage и CaptureControlImage захватывают прямоугольник
 области клиента и элемента управления, соответственно.
 
 Эти четыре функции могут быть использованы для захвата любой
 произвольной области экрана, а также экранных областей форм,
 кнопок, полей редактирования, ComboBox'ов и пр.. Не забывайте
 после работы освобождать используемые вами картинки (Bitmap). }
 




Копирование текста DBMemo

...да, вы забыли упомянуть перед этим о TMemoField. Звучит зловеще (как вы заметили), но это не трудно. Вся хитрость заключается в создании TStringList и перекачивания в него данных для последующего использования. Вот простая процедура без проверок и уведомлений об ошибках, использующая модуль WinCRT:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   I: integer;
   StringList: TStringList;
 begin
   StringList := TStringList.Create;
   try
     StringList.Assign(Table1Memo);
     for I := 0 to StringList.Count - 1 do
       writeln(StringList[I])
   finally
     StringList.Free
   end
 end;
 




Копирование в буфер обмена


 procedure CopyButtonClick(Sender: TObject);
 begin
   if ActiveControl is TMemo then
     TMemo(ActiveControl).CopyToClipboard;
   if ActiveControl is TDBMemo then
     TDBMemo(ActiveControl).CopyToClipboard;
   if ActiveControl is TEdit then
     TEdit(ActiveControl).CopyToClipboard;
   if ActiveControl is TDBedit then
     TDBedit(ActiveControl).CopyToClipboard;
 end;
 
 procedure PasteButtonClick(Sender: TObject);
 begin
   if ActiveControl is TMemo then
     TMemo(ActiveControl).PasteFromClipboard;
   if ActiveControl is TDBMemo then
     TDBMemo(ActiveControl).PasteFromClipboard;
   if ActiveControl is TEdit then
     TEdit(ActiveControl).PasteFromClipboard;
   if ActiveControl is TDBedit then
     TDBedit(ActiveControl).PasteFromClipboard;
 end;
 




Копировать векторное изображение


 procedure TForm1.Button1Click(Sender: TObject);
 var
   mf: TMetaFile;
   mfc: TMetaFileCanvas;
   i: integer;
   ClipBrdFormat: word;
   data: cardinal;
   palette: hPalette;
   p: array [0..90] of TPoint;
 begin
   mf := TMetaFile.Create;
   mf.Width := 100;
   mf.Height := 100;
   mfc := TMetafileCanvas.Create(mf, 0);
   with mfc do
   begin
     Pen.Color := clBlack;
     FrameRect(ClipRect);
 
     MoveTo(0, 50);
     LineTo(100, 50);
     LineTo(95, 48);
     MoveTo(100, 50);
     LineTo(95, 52);
 
     MoveTo(50, 100);
     LineTo(50, 0);
     LineTo(48, 5);
     MoveTo(50, 0);
     LineTo(52, 5);
 
     Brush.Style := bsClear;
     Font.name := 'arial';
     Font.Size := 6;
     TextOut(55, 0, 'Y');
     TextOut(95, 38, 'X');
 
     Pen.Color := clRed;
     for i := low(p) to high(p) do
       p[i] := Point(i, round(50 - 30 * sin((i - 50) / 5)));
     Polyline(p);
   end;
   mfc.Free;
   mf.SaveToClipboardFormat(ClipBrdFormat, data, palette);
 
   OpenClipboard(Application.Handle);
   EmptyClipboard;
   SetClipboardData(ClipBrdFormat, data);
   CloseClipboard;
 
 
   mf.Inch := 200;
   Form1.Canvas.Draw(0, 0, mf);
   mf.Free;
 end;
 




Как скопировать самого себя

Злобный юзверь приходит к админу:
- Вот, у меня Word повис... (уничтожил данные, потерял русские буквы... сами знаете) :(
- А что ты сделал?
- Ну, я (то-то и то-то)...
- А, так он всегда вешается.
- Ну, надо же было сообщение какое нибудь выдать... Или флажок какой поставить...
- Слушай, отстань. Ты когда грузился, большой такой флажок видел?


 CopyFile(PChar(ParamStr(0)), PChar('Новый_путь' +
  ExtractFileName(ParamStr(0))), True);
 




Корпоративное WEB-приложение 1

12 Заповедей от Админа.
1. Прав всегда Админ, ибо в трех лицах есть он единая власть высшая в классе дисплейном!
2. Неправ вечно юзер, ибо прав всегда Админ!
3. Не возжелай ни места, ни системника, ни профиля, ни монитора, ни мыши Админа своего, и да пребудет с тобой вечное благословение его!
4. И если вошел Юзер в систему без высшего на то дозволения (Админа) - горе ему, ибо порушится профиль его!
5. Да убоится юзер установить прогу неустановленную на комп казенный - ибо не дозволено сие!
6. Да не будет превышен профиль юзерский, ибо сказал Админ: "Аз воздам за то обрезанием… профиля твоего!"
7. Не возжелай войти под паролем чужим в систему, ибо надолго потом из дисплейки выйдешь ты!
8. А если кто разрешение на папку сменит - горе юзеру этому, ибо всемогущ в системе своей Админ!
9. Да убоятся пользователи толпиться на местах своих подобно стадам овец безмозглых, ибо всеведущ Админ!
10. И да убоится юзер качать вирусы, ибо админомерзкое занятие сие!
11. А если кто из юзеров возжелает порнухи или чата админа своего - горе и позор ему, ибо высшие удовольствия эти лишь Админу дозволены!
12. А тот юзер, который прочел строки эти и не проникся смирением и не осознал, что тварь он ламероидная и чайник нечищенный в сиянии славы высшего существа Админоподобного - горе ему, ибо навеки отлучены они будут от сети великой!!!
Во имя отца Билли Гейтса, и сына его Microsofta, и святого духа админовского.

На сегодняшний день, создание внутренних корпоративных веб-приложений уже, пожалуй, не просто дань моде, когда все, что так или иначе связано с интернетом считалось популярным и прогрессивным. Нынче менеджеры стали более скупы в раздаче финансов для IT-отделов. Но вместе с тем приходит понимание, что бизнес-приложения предприятий перенесенные на новую технологическую "веб-оснастку" действительно значительно уменьшают издержки по поддержанию данных приложений в актуальном состояние в дальнейшем. Вот краткий перечень достоинств, которыми обладают корпоративные веб-приложения:

  • не требуют инсталляции и обновления клиентского программного обеспечения;
  • снижают затраты на обучение - в качестве клиентской части используется стандартный веб-броузер;
  • пользователи могут работать на любой платформе;
  • логика приложения сосредоточена на стороне сервера;
  • возможность интеграции с ресурсами интерета;
  • создание сколь угодно привлекательного веб-интерфейса.

Если мы будем рассматривать веб-приложения с точки зрения программиста, то представить их можно как некий особый класс систем клиент-сервер, в которых взаимодействие с пользователем осуществляется через стандартный веб-броузер. Если сравнивать структуру веб-приложения и классического приложения, основанного на технологии клиент-сервер, то можно охарактеризовать составляющие компоненты следующим образом:

  • В роли "тонкого клиента", которые отвечает за отображения данных и передачу их от пользователя серверу, выступает броузер. Пользовательский интерфейс всецело определяется HTML-документом, со всеми возможными дизайнерскими ухищрениями.
  • Веб-сервер обеспечивает работу по протоколу HTTP, принимает запросы от клиента, взаимодействует непосредственно с веб-приложением, передает ответы клиенту. Веб-приложение - программа, которая, используя веб-сервер, обрабатывает запросы от клиента, производит необходимые манипуляции с данными, передает ответы клиенту.

Давайте на практическом примере разберем все стадии создания законченного веб-приложения стандартными средствами Delphi 5. О том, насколько расширился диапазон компонентов для веб-приложений в новой версии Delphi 6, мы поговорим отдельно, и в конце цикла статей.

Подобная тема уже рассматривалась на нашем сайте. Смотрите материал "Создание web-приложений в среде Delphi" (www.mcsa.ru/d2.shtml), где достаточно подробно разбирался вопрос, как обычное консольное приложение, созданное в Delphi, без использования визуальных компонентов "превратить" в приложение для веб-сервера. Но сейчас мы рассмотрим создание веб-приложения с использованием специализированных компонентов Delphi.

Создать подобное приложение в Delphi не сложнее, чем стандартную визуальную программу для Windows. Что бы создать новое веб-приложение в Delphi 5, следует выбрать пункт Web Server Application. При этом существуют три различных варианта реализации приложения:

  • ISAPI/NSAPI Dynamic Link Library
  • CGI Stand-alone executable
  • Win-CGI Stand-alone executable

Тут нам придется обратиться к теории, чтобы четко представлять себе разницу между тем или иным типом веб-приложений. Вообще стандартная функциональность веб-сервера, это передача клиенту статических фалов по протоколу HTTP. Но чаще всего требуеться, чтобы информация, поступающая клиенту формировалась динамически. Для того чтобы веб-сервер мог получить, и соответственно передать от приложения данные клиенту, используют интерфейсы веб-сервера.

В общем случае их всего два: API (Application Program Interface - программный интерфейс приложений) и CGI (Common Gateway Interface - общий интерфейс шлюзов). Интерфейс типа API представляет собой традиционный программный интерфейс, вполне привычный для программистов использующих Delphi. При его использование нужно создать динамически загружаемый программный модуль, в котором должен быть реализован набор стандартных функций или классов операционной системы. Но помимо этого, возможно, использовать функции, которые предоставляет веб-сервер. К данному типу можно отнести интерфейсы ISAPI, NSAPI, WSAPI, Apache API, Java Servlet API и другие.

При создание рассматриваемого нами веб-приложения, будет использоваться интерфейс ISAPI, так как именно он реализован в MS IIS (Microsoft Internet Information Server). А именно этот веб-сервер от Microsoft, разумнее всего использовать для поддержки корпоративного веб-приложения. Но обо всем по порядку.

ISAPI (Internet Server Application Programming Interface) - программныей интерфейс, разработанный для сервера. ISAPI изначально был создан как Microsoft Information Server API, но в дальнейшем был предложен в качестве открытого стандарта. С помощью ISAPI возможно создавать два типа динамических модулей для веб-сервера: непосредственно обработчики событий и фильтры.

Обработчик событий представляет собой библиотеку DLL (Dynamic-Link Library), которая загружается и вызывается веб-сервером. Обработчик вызывается веб-сервером при получение клиентского запроса с URL, типа http://server/myapp.dll?запрос. При этом IIS вызывает библиотеку myapp.dll и передает ей параметр "запрос".

Работа обработчика запросов ISAPI происходит в следующей последовательности:

  1. При получение первого клиентского запроса загружается соответствующая dll, создается и инициализируется объект типа CHttpServer.
  2. Для каждого конкретного запроса создается отдельный объект CHttpServerContext. Непосредственно для обработки запроса вызывается метод объекта CHttpServer, которому в качестве параметра передается указатель на CHttpServerContext. При этом, для каждой dll существует только один экземпляр CHttpServer, методы которого исполняются в адресном пространстве веб-сервера одновременно в нескольких потоках, при чем переменные объекта CHttpServer доступны для них всех. Сам объект CHttpServer не выгружается из памяти даже при прекращение выполнения запросов и доступен в течение всего времени работы веб-сервера.

ISAPI-фильтр - это dll, которая загружается на при первом запросе от клиента, а непосредственно при старте IIS и вызывается для обработки определенных событий, возникающих при обращение клиента к веб-серверу. Это может быть как предварительная обработка заголовка клиентского запроса (например на корректность передаваемых данных), действие при ошибочных ситуациях (выдача ошибки 404 File Not Found или др.), авторизация клиента, запись данных в журнал веб-сервера и т.п. Создание ISAPI-фильтра ничем не отличается от создания стандартного ISAPI-приложения. Необходимо будет лишь указать IIS, что та или иная dll является ISAPI-фильтром.

Интерфейс CGI отличается от рассмотренного выше. Принцип его работы сводиться к следующему: веб-сервер запускает внешнею программу (являющуюся веб-приложением) в отдельном процессе операционной системы. При этом сервер устанавливает ряд переменных окружения с которыми взаимодействует приложения. Стандартно это заголовок HTTP-запроса, адрес запрашиваемого документа, строка параметров, в которой могут, к примеру, содержаться данные передаваемые из броузера пользователем и ряд других. Запущенное приложение анализирует данные переменные и в соответствии с внутренней логикой выдает HTTP-заголовок, которые и возвращается клиенту веб-сервером. Время жизни CGI-программы ограничено временем обслуживания пользовательского запроса, по окончанию его выполнения процесс завершается. При этом для каждого отдельного запроса запускается копия веб-приложения. Данные приложения не могут взаимодействовать друг с другом и не имеют программной связи с веб-сервером.

Если сравнивать CGI и API, вернее непосредственно ISAPI, то можно увидеть их достоинства и недостатки. Причем верна такая парадоксальная мысль, что в определенных условиях и для конкретных задач, недостатки одного или другого интерфейса легко "трансформируются" в достоинства. На данный момент CGI наиболее распространенный интерфейс и его поддерживают практически все веб-сервира без необходимости установки дополнительных модулей. CGI-программа может создаваться с использованием любого языка и средства разработки, поскольку запускается как независимый от веб-сервера процесс и строго говоря, зависимо только от операционной системы.

Преимуществом создания веб-приложений с использованием CGI является их относительная большая надежность и безопасность для веб-сервера, так как они выполняются независимо и даже в случае краха вряд ли могут привести к нарушению функциональности веб-сервера в целом. Веб-приложения использующие CGI обладают и рядом недостатков. При обработки большого количества запросов, веб-сервер испытывает значительные нагрузки, так как для каждого запроса необходимо отдельно заново запускать приложение. К тому же не имеется возможности взаимодействовать с данными, поступающими от других запущенных приложений и веб-сервера (кроме переменных окружения), что не позволяет создать достаточно масштабные и сложные проекты.

Основным преимуществом использования ISAPI можно считать то, что они, взаимодействуя с веб-сервером и объектами запросов поступающих от других пользователей позволяют создавать многопользовательские приложения. Это особенно важно при создание многопользовательских приложений работающих с базами данных и имеющих сложную логику. В качестве примера можно привести чаты, где например каждый обработчик событий может обращаться к общему для всех запросов списку сообщений. Или интернет-магазин использующий список выбранных в корзину товаров. Главнй недостаток ISAPI, что данный интерфейс поддерживается исключительно сервером MS ISS. Кроме того, при некорректной работе ISAPI-приложения возможны сбои в работе всего веб-сервера.

Еще одна существующая угроза, заключена в следующем: ввиду того, что IIS весьма часто подвергается хакерским атакам и вообще не очень надежный сервер использовать его как полноценные веб-сервер вне корпоративной сети, скорее всего не стоит. Но в том случае, если IIS будет использован как внутренний корпоративный веб-сервер, с использованием веб-приложений - это практически идеальный вариант.

Почему мы все же выбираем ISAPI-приложение, если есть возможность создания (и средствами Delphi в том числе) приложенный для CGI, ASP и т.д.? Дело в том, что подобные веб-приложения быстрее и требуют меньших ресурсов. Веб-приложение основанное на ISAPI многопоточно, и для обработки запроса клиента не требуется загрузки еще одной копии приложения. По сравнению с тем же пресловутым ASP, они имеют гораздо больший перечень функциональных возможностей. Например, можно использовать все множества функций Win32 API без необходимости писать для этого COM-объекты и существенно выигрывают по скорости, за счет того, что их код уже откомпилирован и оптимизирован. Веб-приложения основанные на ISAPI кроме того легко создаются из любого уже существующего приложения. Если оно было написано на Delphi, то все может совестить к тому, чтобы заменить визуальные объекты на специальные веб-компоненты, не переписывая ту часть, где сосредоточена сама логика приложения, и его работа, например с базами данных.

В следующей части материала мы определим непосредственно логику приложения и структура баз данных. А также создадим веб-интерфейс приложения и рассмотрим особенности модуля Delphi WebModule.




Корпоративное WEB-приложение 2

Сын спрашивает у папы программиста:
- Пап, откуда дети берутся?
- Отстань сынок, я занят, спроси у Яндекса!

В предыдущем материале мы рассмотрели особенности работы и различия в реализации ISAPI/NSAPI и CGI приложений для веб-сервера. Теперь настал черед использовать полученные навыки на практике.

Так как мы будем создавать ISAPI-приложение, то соответственно необходимо, чтобы на компьютере был установлен IIS. В Windows 9.xx он также именуется как Personal Web Server и находиться обычно в папке PWS инсталляционного диска. Для установки IIS в Windows 2000 необходимо выбрать компоненты служб IIS при установке или добавление компонентов Windows.

Для создания ISAPI-приложения в Delphi необходимо создать новый проект Web Server Application. Как видите по умолчанию сразу же доступен специальный модуль WebModule. Он является обязательным и дает возможность веб-приложению ответить на запрос HTTP, пропуская запрос и ответ к соответствующим обработчикам ActionItems. Приложение может содержать только один WebModule.

Так как это основной объект, с которым придется работать, создавая веб-приложение, стоит рассмотреть WebModule подробнее. К главным событиям WebModule относятся:

OnCreate
Это событие происходит в тот момент, когда приложение создает WebModule. Чаще всего его следует использовать для инициализации переменных и объектов, содержащихся в приложении.
OnDestroy
Происходит перед уничтожением WebModule. Здесь желательно производить освобождение объектов, созданных динамически в приложении.
BeforeDispatch
Событие происходит перед тем, как диспетчер устанавливает соответствие запроса HTTP с ActionItems.
AfterDispatch
Происходит после того, как HTTP ответ был успешно сформирован ActionItems, но еще не передан клиенту.

Создавая ISAPI приложения, нужно помнить, что объект WebModule может быть создан один раз и не создаваться при каждом запросе, следовательно, не будут генерироваться события OnCreate и OnDestroy объекта WebModule.

WebModule имеет два важных свойства Request и Response, с помощью которых принимает и передает данные IIS. Response - автоматически создаваемый объект WebModule, содержащий информацию, которая будет передана клиенту, в результате обработки запроса. После того как все свойства Response будут заполнены, будет сформирован HTTP ответ, который и будет передан клиенту.

Среди свойств объекта Response существуют следующие:

ContentType
Тип содержимого HTTP ответа в соответствии со спецификацией MIME. Его необходимо использовать, чтобы установить тип содержимого передаваемого клиенту. Если к примеру нужно передать изображение в формате GIF, необходимо установить ContentType = 'image/gif'.
Content
Содержит непосредственно информацию, передаваемую клиенту в ответ на сообщение запроса HTTP.
ContentStream
Определяет Stream объект, который будет передан клиенту. Используют в основном для передачи клиенту содержимого отличного от ContentType = 'text/*'.
Request
Также автоматически создаваемый объект WebModule, с помощью которого можно получить информацию от пользователя. В принципе Request представляет текущий HTTP запрос в удобной для обработке форме. Его основные свойства:
ContentFields
Предоставляет содержимое полей POST запроса.
QueryFields
Предоставляет содержимое GET запроса. То есть извлекает необходимый параметр, передаваемый приложению из url. Как ContentFields, так и QueryFields возвращаю параметры в виде "имя = значение".

Пойдем дальше. Попробуем создать простейшее веб-приложение, что-то вроде новой вариации "Hello, world!" для IIS. WebModule у нас уже создан. Теперь возьмем с закладки компонентов Delphi Internet, компонент PageProducer, что отвечает за выдачу HTML-документа.

В свойстве HTMLDoc PageProducer наберем всем известное "Hello, world!". Теперь необходимо создать Add Item - новый обработчик событий. Сделаем так, чтобы он запускался по умолчанию. Для этого переведем свойство Default из False в True. И заключительный шаг - укажем обработчику на то, что он должен выдавать результат созданного PageProducer. В свойстве Producer выберем PageProducer.

Наше веб-приложение готово. Готовый dll нужно скопировать в каталог веб-сервера и запустить его через броузер, по адресу вроде http://localhost/cgi-bin/Project1.dll. В окне броузера должно появиться приветствие "Hello, world!".

На сегодня это пока все. В следующий раз попробуем создать что-то более существенное, например, подключиться к базе данных.




Корректное закрытие базы данных приложением Delphi

Очень интересный и полезный вопрос!! Я сам так с ним до конца и не разобрался! Но я попробую систематизировать события, происходящие при запросе на завершение работы Windows:

  1. Windows посылает сообщение WM_QUERYENDSESSION главным окнам всех запущенных приложений, при этом приложения должно сообщить свою готовность к завершению работы.

    Если при этом хотя бы одно из приложений ответит отрицательно, Windows прерывает процесс завершения работы.

  2. Delphi перехватывает это сообщение, и, в свою очередь, вызывает метод TForm.CloseQuery, (в главной форме, естественно), который генерирует событие OnCloseQuery, в обработчике которого можно указать на неготовность завершения приложения и отмены завершения работы Windows.

  3. Если я правильно понимаю, если ваше приложение "не мешает" Windows завершить свою работу, Windows нормально НЕ завершает работу приложения, поскольку для этого нет необходимости, не нужно освобождать память, ресурсы и пр. Так, если это утверждение верно (это легко можно проверить, но я слишком ленив сейчас), то событие OnCloseQuery - ваш единственный шанс сохранения данных на диске. Я не думаю что эта логика слишком плоха, просто это одна из тех причуд Windows, которую нужно знать и пользоваться ею. Что может произойти в описанном выше сценарии: редактируемая в настоящий момент запись не будет отправлена (Post) в базу данных, но та же самая вещь может случиться и при нормальном завершении приложения.

    При выходе из windows, вы вызываете WM_CLOSE api (или что-то типа этого) для каждого работающего в настоящий момент приложения. Программа закрывается точно таким же образом, как если бы вы щелкнули на кнопке закрытия или вызвали close из главной формы. Поэтому вам не нужно предпринимать никаких дополнительный действий, связанных с завершением работы с таблицами.




Как правильно соединяться с базой данных под Personal Oracle

Автор: Nomadic

A: user/password@2: Это так для Oracle SQL Plus, и более других его утилит. А в BDE надо оставить все как для соединения с сетевым сервером, (протокол TNS, имя пользователя, кодировку, интерфейсную DLL) только вместо имени сервера написать "2:". Это годится и для случая, когда на одной машине и сетевой сервер и приложение.




Как реализовать визуальный отсчет времени

Автор: Cobalt


 var Min3: integer;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   timer1.enabled:=true;
   Min3:=3*60;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   Label1.Caption:=Format('%d : %2d',[Min3 div 60, Min3 mod 60 ]);
   Dec(Min3);
   if Min3 < 0 then
     // Что-то делаешь - 3 минуты закончились
 end;
 




Как узнать число кадров AVI файла, и выяснить как долго будет проигрываться этот файл

Звонок в фирму:
- Сколько байтов в вашем компьютере?
- ??? Сколько надо, столько и будет!
- А сколько надо для мультивидео?


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   MediaPlayer1.TimeFormat := tfFrames;
   ShowMessage('Number of frames = ' + IntToStr(MediaPlayer1.Length));
   MediaPlayer1.TimeFormat := tfMilliseconds;
   ShowMessage('Number of milliseconds = ' + IntToStr(MediaPlayer1.Length));
 end;
 




Алгоритм подсчёта времени, которое ушло на какую-либо операцию

Интернациональная встреча Нового Года (2000). Американец, хвастаясь успехами своей страны: - А вот у нас, в Америке .... Наш _ВОЕННЫЙ_ программер, поднимая лицо из тарелки с салатом: - А вот нет больше твоей Америки Американец, обливаясь холодным потом: - Как нет?? Почему?? Наш, пуская пузыри в салат (неразборчиво): - А у нас проблема 2000 была на 12 часов раньше ....


 var
   OperBegin, OperEnd: TTimeStamp;
   Total: LongWord;
 
 begin
   OperBegin := DateTimeToTimeStamp(Now); {запоминается момент начала операции}
 
   {Здесь размещается код операции}
 
   OperEnd := DateTimeToTimeStamp(Now); {запоминается момент окончания операции}
   Total := OperEnd.Time - OperBegin.Time;
 end;
 




Работа с портами микропроцессора

Автор: Pavlo Zolotarenki

Отряд милиции особого назначения разогнал толпу бунтующих программистов.... до 1ГГц.

Модуль для работы с портами микропроцессора с сохранением синтаксиса.
Работает под Win9x.
НЕ работает под WinNT.


 //Copyright(c) 1998 Zolotarenko P.V pvz@mail.univ.kiev.ua
 
 unit Ports;
 interface
 type
 
   TPort = class
   private
     procedure Set_(index_: word; value: byte); register;
     function Get_(index_: word): byte; register;
   public
     property Element[index_: word]: byte read Get_ write Set_; default;
   end;
 
   TPortW = class
   private
     procedure Set_(index_: word; value: Word); register;
     function Get_(index_: word): word; register;
   public
     property Element[index_: word]: word read Get_ write Set_; default;
   end;
 
 var
   Port: TPort;
 
   PortW: TportW;
 
 implementation
 
 procedure TPort.Set_(index_: word; value: byte);
 begin
 
   asm
 mov dx,index_
 mov al,value
 out dx,al
   end;
 end;
 
 function TPort.Get_(index_: word): byte;
 begin
 
   asm
 mov dx,index_
 in al,dx
 mov @Result,al
   end;
 end;
 
 procedure TPortW.Set_(index_: word; value: word);
 begin
 
   asm
 mov dx,index_
 mov ax,value
 out dx,ax
   end;
 end;
 
 function TPortW.Get_(index_: word): word;
 begin
 
   asm
 mov dx,index_
 in ax,dx
 mov @Result,ax
   end;
 end;
 
 initialization
 
   Port := TPort.Create;
   PortW := TPortW.Create;
 
 finalization
 
   Port.free;
   PortW.free;
 end.
 




Как получить информацию о загрузке процессора

Автор: Nomadic

Сообщение Windows: "CPU not found. Software emulation".

Читать из реестра HKEY_DYN_DATA\PerfStats\StatData соответствующий ключ Kernel \CPUUsage.




Взлом программ это просто - электронная кулинарная книга

Автор: Fess

K хакеру подходит ламер, протягивает исходник своей неработающей программы и спрашивает:
- Где у меня ошибка?
- В ДHK!!!

Target: Электронная кулинарная книга 3.3

Tools:

  • Some brains
  • Soft-Ice v3.4
  • Pe Identifier 0.7 beta
  • Win32Dasm 8.93
  • Caspr 1.100
  • ProcDump 1.6.2
  • C2C 0.06b (Compare2Crack)
  • Hex-editor (QView,Hiew)

Итак. Приступим.

Что же меня на это побудило? Да сущий пустяк, читал я как-то о новых прогах на www.softodrom.ru и натолкнулся на новую версию этой проги 3.3. Стал скачивать не пашет, еще попробовал эффект тот же. Полез на ихний сайт попытался там скачать не помогло. И пока не мог скачать смотрел отзывы об этой проге, и там было написано. Что жалко нету кряка к ней. Ну я подумал, дай думаю поисследую эту прогу. Искал ее везде и нашел на сервере www.pcsoft.ru или www.softpc.ru не помню точно.

Поехали...

Первое, что надо сделать это запустить Pe Identifier (peid.exe). Копируем его в каталог с программой и пишем командочку peid.exe kulinar.exe. Так... Он нам выдает, что прога-то оказывается пакована AsProtect 1.2. Интересно, интересно. (Помню ломал более старую версию проги 2.1 и она не была запакована ничем, и номер в ней считался так: ключ делим 2DDh, округляем и прибавляем к полученному 1E80A4. Легко не правда-ли? Теперь я почувствовал, что автор поберегся...)

Но и на AsProtect найдется управа, достаем Caspr. Он так же входит в состав программы UnPack. Копируем его в каталог с программой и набираем следующую комманду: caspr.exe kulinar.exe. После этого в каталоге на один файл стало больше. Х-м-м... Откуда однако? А!!!! Должно быть это и есть распакованный файл он называется kulinar.ex_. Хорошо, хорошо, потираем руки мы. И продолжаем свой нелегкий труд.

Опять запускаем peid.exe, но уже с параметром kulinar.ex_. И видим, что программка, то написана на Делфях, а на них то ж и ежу понятно защитить путно НЕВОЗМОЖНО. На мыслю сразу приходят огромные вложенности и другая ерунда.

Пришла пора запустить Soft-Ice. Запускаем прогу, переходим на вкладку Регистрация. И в место сер.ном. вводим 110022334455, так легче всего искать строку в памяти. Нажимаем Ctrl-D, вываливаемся в Soft-Ice. Пишем

s 0 l fffffffff "1100223344". Нажимаем Enter.
Что тут и зачем спросите вы.
s - указывает, что это поиск.
0 - это адрес с которого начинать искать.
l - указывает, что дальше идет длинна.
fffffffff - длинна области поиска данных.
"1100223344" - строка которую мы ищем.

У меня она нашлась на 80510EF2. Ставим бряк на эту область памяти. Ведь проге эту строчку считывать когда-нибудь надо, а? Это делается командой bpmb <адрес>, т.е. у меня это bpmb 80510EF2 Ввели. Хорошо. Нажимаем кнопку "Зарегистрировать" и вываливаемя в Soft-Ice. Далее все просто. Нажимаем F12 не вывалимся в программу kulinar.exe, здесь для этого надо нажать 7 раз. Потом нажимаем на F12 еще несколько раз пока не увидим присвоение eax адреса в памяти (5 раз), и там будут такие строки (взято из Win32Dasm)


 :004EF314 8B8530FEFFFF            mov eax, dword ptr [ebp+FFFFFE30]
 :004EF31A 50                      push eax
 :004EF31B 8D8528FEFFFF            lea eax, dword ptr [ebp+FFFFFE28]
 :004EF321 E80286FFFF              call 004E7928
 :004EF326 FFB528FEFFFF            push dword ptr [ebp+FFFFFE28]
 :004EF32C 6868F44E00              push 004EF468
 :004EF331 8D8524FEFFFF            lea eax, dword ptr [ebp+FFFFFE24]
 :004EF337 E8006FF7FF              call 0046623C
 :004EF33C FFB524FEFFFF            push dword ptr [ebp+FFFFFE24]
 :004EF342 8D852CFEFFFF            lea eax, dword ptr [ebp+FFFFFE2C]
 :004EF348 BA03000000              mov edx, 00000003
 :004EF34D E8324CF1FF              call 00403F84
 :004EF352 8B952CFEFFFF            mov edx, dword ptr [ebp+FFFFFE2C]
 :004EF358 58                      pop eax
 :004EF359 E8764CF1FF              call 00403FD4
 :004EF35E 0F85BA000000            jne 004EF41E
 :004EF364 8B15DCBD4F00            mov edx, dword ptr [004FBDDC]
 :004EF36A 8B12                    mov edx, dword ptr [edx]
 

После выполнения строки 4EF314 по адресу в eax будет находится адрес нашей строки. Строка 4EF35E сразу кажется нам подозрительной, что это за условный переход после выполнения процедуры? Возможно ли, что это процедура сравнения? И что заносится в edx и eax перед выполнением процедуры? Проверим!!!!

Удаляем точку останова (бряк) на памяти командой bc *. И доходим нажимая F10 до строки 4EF352. Выполняем ее. Пишем команду d edx (показать область памяти по адресу edx). Там мы видим какую-то строку очень напоминающую серийный номер. Переписываем на мятый и валяющийся тут же рядом листок бумаги знававший лучшие времена. Мало ли, вдруг пригодится? Выполняем следующую строчку и пишем команду d eax, там как ни странно находится наш введенный номер. После этого у нас не остается сомнений, что номер верен. Проверим?!!!! Воодим куда следует и программа нас хвалит, что все законно и рульно. И все бы вроде бы хорошо, да вот только зачем автор приписал Win32Dasm в инструменты. Да-да-да именно за тем... и вам того же. А вообще-то, решия я сбацать keygen давно хотел. А бацать мы его будет не на чем нибудь, а сделаем из этой же программы. Дизассмемблирем его. Что? Не получается? А попробуйте так. Запустите ProcDump выберите PeEditor Выберите распакованный файл. Нажмите кнопку Sections. На самой верхней секции нажмите правой кнопкой мыши и выберите Edit section, в поле Characteristics введите вместо C0000040 строку E0000020. Кому интересно почему так, а не иначе обращайтесь к стандарту PE файлов. Теперь можете дизассемблировать.

Я тут подумал и решил сделать вывод номера функцией MessageBoxA Формат команды такой


 MessageBoxA(идентификатор окна, заголовок,текст,атрибуты)
 

Т.е. наш текст на асме будет выглядеть так:


 push 0 ; идентификатор окна
 push edx ;заголовок - где edx адрес правильного номера
 push edx ;текст - где edx адрес правильного номера
 push 0 ; аттрибуты стандартные
 call MessageBoxA ;Вызов процедуры генерации окна
 

Т.к. я не догнал как вызвать MessageBoxA в уже скомпилированной проге решил вызвать какой-нибудь из уже существующих с нашмими параметрами. Я решил взять по адресу 40C26F. Т.е. введем push'и и прыгнем jump'ом. Писать будем начиная 4EF358 программу все равно запорем. Теперь переименовываем файл kulinar.ex_, который мы распаковали и дисассемблировали в kulcrk.exe. Копируем сюда же qview. Набираем в командной строке: qview kulcrk.exe. Нажимаем Enter, вошли. Т.к. у Delphi реальные адреса в программе не совпадают с виртуальными (в памяти), то придется искать по сигнатуре. Т.е. ищем сначала такую строку E8324CF1FF8B952CFEFFFF для этого переходим в режим дизассемблера два раза F4. И в режим 32 бит. F2 один раз. Такая строка встречается 1 раз по адресу EE758 приглядывамся, это она и есть значит здесь 4EF358=EE758. Теперь ищем Call MessageBoxA, если подумать, то его можно узнать выразив из разницы значений 4EF358-EE758= 400C00, значит если в памяти MessageBox находится по адресу 40C26F значит реально он находится 40C26F - 400C00 = B66f. Теперь с адреса EE758, нажав Tab начинаем писать :


 push 0
 push edx
 push edx
 push 0
 jmp B66f
 

Теперь если все написали, сохраняем и запускаем этот файл. По идее, если все делали правильно, то при вводе неправильного или правильного номера, появляется окно, в котором правильный номер будет написан. Переписываем его. Запускаем нормальный файл, вводим правильный номер и РУЛЛЛЕЗЗЗ!!!!!

Все кончено, программа сломана без особых ухищрений. На последок могу только сказать товарищи программисты не будьте так наивны.

Все просто ибо бытие состоит из простых вещей, и в нереальности невозможно отличить простое от сложного.

Компьютер бесценен, ибо есть критерии по которым его оценить нельзя!

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

З.Ы. Возможны ошибки. Взлом игры 3 минуты. Написание статьи 50 минут, видите как старался.

With best wishes Fess




CreateProcess, который возвращает консольный вывод

- Можно ли научить слона работать в Windows?
- Нет, он ведь боится мышей.


 procedure ExecConsoleApp(CommandLine: AnsiString; Output: TStringList; Errors:
   TStringList);
 var
   sa: TSECURITYATTRIBUTES;
   si: TSTARTUPINFO;
   pi: TPROCESSINFORMATION;
   hPipeOutputRead: THANDLE;
   hPipeOutputWrite: THANDLE;
   hPipeErrorsRead: THANDLE;
   hPipeErrorsWrite: THANDLE;
   Res, bTest: Boolean;
   env: array[0..100] of Char;
   szBuffer: array[0..256] of Char;
   dwNumberOfBytesRead: DWORD;
   Stream: TMemoryStream;
 begin
   sa.nLength := sizeof(sa);
   sa.bInheritHandle := true;
   sa.lpSecurityDescriptor := nil;
   CreatePipe(hPipeOutputRead, hPipeOutputWrite, @sa, 0);
   CreatePipe(hPipeErrorsRead, hPipeErrorsWrite, @sa, 0);
   ZeroMemory(@env, SizeOf(env));
   ZeroMemory(@si, SizeOf(si));
   ZeroMemory(@pi, SizeOf(pi));
   si.cb := SizeOf(si);
   si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
   si.wShowWindow := SW_HIDE;
   si.hStdInput := 0;
   si.hStdOutput := hPipeOutputWrite;
   si.hStdError := hPipeErrorsWrite;
 
   (* Remember that if you want to execute an app with no parameters you nil the
      second parameter and use the first, you can also leave it as is with no
      problems.                                                                 *)
   Res := CreateProcess(nil, pchar(CommandLine), nil, nil, true,
     CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, @env, nil, si, pi);
 
   // Procedure will exit if CreateProcess fail
   if not Res then
   begin
     CloseHandle(hPipeOutputRead);
     CloseHandle(hPipeOutputWrite);
     CloseHandle(hPipeErrorsRead);
     CloseHandle(hPipeErrorsWrite);
     Exit;
   end;
   CloseHandle(hPipeOutputWrite);
   CloseHandle(hPipeErrorsWrite);
 
   //Read output pipe
   Stream := TMemoryStream.Create;
   try
     while true do
     begin
       bTest := ReadFile(hPipeOutputRead, szBuffer, 256, dwNumberOfBytesRead,
         nil);
       if not bTest then
       begin
         break;
       end;
       Stream.Write(szBuffer, dwNumberOfBytesRead);
     end;
     Stream.Position := 0;
     Output.LoadFromStream(Stream);
   finally
     Stream.Free;
   end;
 
   //Read error pipe
   Stream := TMemoryStream.Create;
   try
     while true do
     begin
       bTest := ReadFile(hPipeErrorsRead, szBuffer, 256, dwNumberOfBytesRead,
         nil);
       if not bTest then
       begin
         break;
       end;
       Stream.Write(szBuffer, dwNumberOfBytesRead);
     end;
     Stream.Position := 0;
     Errors.LoadFromStream(Stream);
   finally
     Stream.Free;
   end;
 
   WaitForSingleObject(pi.hProcess, INFINITE);
   CloseHandle(pi.hProcess);
   CloseHandle(hPipeOutputRead);
   CloseHandle(hPipeErrorsRead);
 end;
 
 (* got it from yahoo groups, so no copyrights for this piece :p and and example
    of how to use it. put a button and a memo to a form.                      *)
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   OutP: TStringList;
   ErrorP: TStringList;
 begin
   OutP := TStringList.Create;
   ErrorP := TstringList.Create;
 
   ExecConsoleApp('ping localhost', OutP, ErrorP);
   Memo1.Lines.Assign(OutP);
 
   OutP.Free;
   ErrorP.Free;
 end;
 




Как использовать CreateWindow(Ex)

Автор: lel

Для пеpехода к следующей ошибке нажмите кнопку ДАЛЕЕ.


 program winmin;
 
 uses
  windows,
  messages;
 var   wc : TWndClassEx;
 MainWnd : HW   Mesg : TMsg;
 
 function WindowProc(wnd:HWND; Msg : Integer; Wparam:Wparam;
  Lparam:Lparam):Lresult;
 stdcall;
 Begin
 case msg of
 wm_destroy :
  Begin
   postquitmessage(0); exit;
   Result:=0;
  End;
 
  else Result:=DefWindowProc(wnd,msg,wparam,lparam);
 end;
 
 End;
 var xPos,yPos,nWidth,nHeight : Integer;
 begin
 wc.cbSize:=sizeof(wc);
 wc.style:=cs_hredraw or cs_vredraw;
 wc.lpfnWndProc:=@WindowProc;
 wc.cbClsExtra:=0;
 wc.cbWndExtra:=0;
 wc.hInstance:=HInstance;
 wc.hIcon:=LoadIcon(0,idi_application);
 wc.hCursor:=LoadCursor(0,idc_arrow);
 wc.hbrBackground:=COLOR_BTNFACE+1;
 wc.lpszMenuName:=nil;
 wc.lpszClassName:='WinMin : Main';
 
 RegisterClassEx(wc);
 xPos:=100;
 yPos:=150;
 nWidth:=400;
 nHeight:=250;
 
 MainWnd:=CreateWindowEx(
 0,
 'WinMin : Main',
 'Win Min',
 ws_overlappedwindow,
 xPos,
 yPos,
 nWidth,
 nHeight,
 0,
 0,
 Hinstance,
 nil
 );
 
 
 ShowWindow(Mai! nWnd,CmdShow);
 While GetMessage(Mesg,0,0,0) do
 begin
  TranslateMessage(Mesg);
  DispatchMessage(Mesg);
 end;
 
 end.
 




Как программно создать Alias


 procedure TForm1.Button3Click(Sender: TObject);
 var
   MyList: TStringList;
 begin
   MyList := TStringList.Create;
   try
     with MyList do
     begin
       Add('SERVER NAME=IB_SERVER:/PATH/DATABASE.GDB');
       Add('USER NAME=MYNAME');
     end;
     Session1.AddAlias('NewIBAlias', 'INTRBASE', MyList);
   finally
     MyList.Free;
   end;
 end;
 




Как программно создать Alias 2


 procedure CreateAlias();
 const
   DlPs = 5;
 var
   wrstr, wrstr1 :string;
   AParams: TStringList;
   Psevdonm: array [1..DlPs] of string;
   i: integer;
 begin
   //Заполним массив
   Psevdonm[1] := 'TERMNNSI,NSI'; // имя,каталог
   Psevdonm[2] := 'TERMNBASE,BASE';
   Psevdonm[3] := 'TERMNTNL,BASE\TNL';
   Psevdonm[4] := 'TERMNARH,ARH';
   Psevdonm[5] := 'TERMNTELE,TELE';
   // if not DirectoryExists(datapath) then begin
   // createdir(datapath) ;
   // end;
   for i := 1 to DlPs do
   begin
     // Для начала проверим каталоги
     wrstr1 := Copy(Psevdonm[i],Pos(',',Psevdonm[i])+1, Length(Psevdonm[i])-Pos(',',Psevdonm[i])+1);
     if not DirectoryExists(wrstr1) then
     begin
       CreateDirectory(PChar(CurrntDir+'\'+wrstr1),nil);
     end;
 
     // Если нет псевдонима, то создадим или подправим
     wrstr := Copy(Psevdonm[i],1,Pos(',',Psevdonm[i])-1);
     if not Session.IsAlias(wrstr) then
     begin
       try
         Session.AddStandardAlias(wrstr,wrstr1,'PARADOX');
         Session.SaveConfigFile;
       except
         SaveTekJrn('ERR:Ошибка создания алиаса - '+wrstr);
         Exit;
       end;
     end;
     //Настроим алиас
     AParams := TStringList.Create;
     AParams.Add('PATH=' + CurrntDir+'\'+wrstr1);
     Session.ModifyAlias(wrstr,AParams);
     Session.SaveConfigFile;
     // Освобождение списка
     AParams.Free;
   end;
 end;
 




Создание алиасов


 procedure CheckAlias(const AliasName, AliasType, AliasPath: String);
 { Если алиас не существует, создать его }
 var
   SList: TStrings;
   i: Integer;
   AliasFound: Boolean;
 begin
   { Проверка существования алиса BDE }
   try
     SList := TStringList.Create;
     Session.GetAliasNames(SList);
     AliasFound := False;
     for i:=0 to SList.Count-1 do
       if SList[i]=AliasName then
         begin
           AliasFound := True;
           break;
         end;
   finally
     SList.Free;
   end;
   if AliasFound then
     begin
       try
         SList := TStringList.Create;
         Session.GetAliasParams(AliasName,SList);
         {А в 4-ой версии SList[2]!!! и без слова Path }
         if SList[0]< > 'PATH='+AliasPath then { Правильно ли задан путь }
           begin
             SList[0] := 'PATH='+AliasPath;
             Session.ModifyAlias(AliasName,SList);
           end;
       finally
         SList.Free;
       end;
     end
   else
     Session.AddStandardAlias(AliasName,AliasPath,AliasType); { Создать новый алиас }
   Session.SaveConfigFile;
 end;
 




Как создать все поддиректории за один проход

Пример использует информационное поле (label) и кнопку на форме. Когда пользователь кликает по кнопке, то все поддиректории, содержащиеся в пути создаются (если они ещё не созданы). Результат записывается в текстовое поле:


 uses FileCtrl;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Dir: string;
 begin
   Dir := 'C:\APPS\SALES\LOCAL';
   ForceDirectories(Dir);
   if DirectoryExists(Dir) then
     Label1.Caption := Dir + ' was created'
 end;
 




Создание и удаление полей во время выполнения программы

TField-компоненты (или, точнее, потомки компонента TField с соответствующим типом поля) могут создаваться во время проектирования программы с помощью Fields Editor (редактора полей). Fields Editor вызывается двойным щелчком на иконке компонента TTable или TQuery. Но потомки TField могут быть созданы и удалены и в режиме выполнения программы.

Потомки компонента TField (такие как, например, TStringField, TIntegerField и др.) создаются методом Create для того типа потомка TField, который подходит к соответствующему полю набора данных. Другими словами, для поля строкового типа текущего набора данных необходимо вызвать метод Create класса TStringField, являющегося потомком TField. Методу Create необходим один параметр - владелец потомка TField, расположенный на TForm. После создания компонента наследника TField для того, чтобы новый экземпляр объекта мог установить связь с необходимым полем набора данных, необходимо установить несколько ключевых свойств. Вот их список:

  • FieldName: имя поля в таблице
  • Name: уникальный идентификатор компонента-потомка TField.
  • Index: позиция компонента-потомка TField в массиве TFields (свойство Fields компонента TTable или TQuery, с которым будет связан TField).
  • DataSet: компонент TTable или TQuery, с которым будет связан TField.

Приведенный ниже код демонстрирует способ создания TStringField. TForm названа Form1 (здесь ссылка на переменную Self), активный набор данных TQuery имеет имя Query1 и поле, для которого создается компонент TStringField, расположено в таблице dBASE с именем CO_NAME. Новый потомок TField будет вторым TField в свойстве-массиве Fields компонента Query1. Имейте в виду, что набор данных, связанный с новым потомком TField (в нашем случае Query1), перед добавлением TField должен быть закрыт, а после добавления вновь открыт.


 procedure TForm1.Button2Click(Sender: TOObject);
 var
   T: TStringField;
 begin
   Query1.Close;
   T := TStringField.Create(Self);
   T.FieldName := 'CO_NAME';
   T.Name := Query1.Name + T.FieldName;
   T.Index := Query1.FieldCount;
   T.DataSet := Query1;
   Query1.FieldDefs.UpDate;
   Query1.Open;
 end;
 

Вышеприведенный пример создает новый TStringField с именем Query1CO_NAME.

Для удаления существующего потомка TField достаточно вызова метода Free данного компонента. В примере, приведенном ниже, метод TForm FindComponent используется для получения указателя на компонент TStringField с именем Query1CO_NAME. Возвращаемая функцией FindComponent величина в случае успешного завершения будет иметь тип TComponent или nil в противном случае. Возвращаемое значение может использоваться для того, чтобы определить, действительно ли существует компонент до того, как будет применен метод Free.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   TC: TComponent;
 begin
   TC := FindComponent('Query1CO_NAME');
   if not (TC = nil) then
   begin
     Query1.Close;
     TC.Free;
     Query1.Open;
   end;
 end;
 

Как и при создании TField, набор данных, связанный с потомком TField и активный в настоящий момент, перед вызовом данного метода должен быть закрыт и впоследствии вновь активирован.




Создание объектов любого типа

CLASSES.PAS определяет функцию с именем FindClass, возвращающую классовую ссылку на этот класс (такую же, как и при регистрации класса). Вот пример, который динамически создает компоненты на основе имени класса, введенного в поле редактирования. Не забывайте при этом вызвать RegisterClasses и перечислять все возможные классы, которые вы имеете намерение создать.


 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Grids, DBGrids, ExtCtrls, DBCtrls, DB, DBTables;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Edit1: TEdit;
     procedure Button1Click(Sender: TObject);
   public
     NextTop: integer;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   NewObj: TControl;
   NewClass: TPersistentClass;
 begin
   NewClass := FindClass(Edit1.Text);
   NewObj :=
     TControl(TComponentClass(NewClass).Create(Self));
   NewObj.Parent := Self;
   NewObj.Name := NewObj.ClassName + IntToStr(NextTop);
   NewObj.Top := NextTop;
   NextTop := NextTop + 20;
 end;
 
 initialization
   RegisterClasses([TButton, TEdit, TLabel]);
 end.
 




Создание autoincrement поля

Согласно электронной документации по DBD, "автоприращиваемое" (Autoincrement) поле таблиц Paradox должно содержать значение Valcheck Minimum value.

Это отлично работает с новой таблицей, но вы не сможете добавить Аutoincrement поле к существующей таблице, т.к. все значения Valchecks неактивны!

Решение: измените тип поля с + на N, установите минимальное значение и восстановите тип поля на +.




Создание банковского ключа


 function CheckCtrlKey( aNLs : string; aMfo : real ) : boolean;
 const
   {12345678901234567890xxx}
   msk : string[28]= '71371371371371371371713';
 var
   i : byte;
   s : integer;
   nls : string[28];
   bic : string[10];
 begin
   bic := LeftPad( Real0Str( aMfo, 9, 0 ), 9 );
   if bic[7] < >  '0' then {< =Простая проверка -- это РКЦ?}
     { не учитывает ГРКЦ }
     nls := bic[7]+bic[8]+bic[9]
   else
     nls := '0'+ bic[5]+bic[6]; { РКЦ }
   nls := aNLs + nls;
   s:= 0;
   for i := 1 to 23 do
     s := s + ( ( (byte(nls[i])-48) * (byte(msk[i])-48) ) mod 10 );
   s := s mod 10;
   CheckCtrlKey := s = 0;
 end;
 




Создание больших массивов

Программист с женой отправились в супермаркет. Сделав все необходимые закупки, они вышли на улицу, и жена сказала:
- Стой здесь и смотри в оба за этими десятью сумками, пока я схожу и разыщу такси.
Когда жена вернулась, то увидела обалдевшего мужа, переставляющего сумки с места на место. Программист:
- Ты сказала, что здесь десять сумок, а я насчитал только 9!
Жена:
- Hо их было десять!
Программист:
- Hет, давай вместе считать: 0, 1, 2, 3...

В 16-битной версии Delphi нельзя сделать это непосредственно. В новой, 32-битной версии, это как-то можно сделать, но за два месяца колупания я так и не понял как. (Некоторые бета-тестеры знают как. Не могли бы они сообщить нам всю подноготную этого дела?)

В 16-битной версии Delphi вам необходимо работать с блоками по 32K или 64K и картой. Вы могли бы сделать приблизительно следующее:


 type
 chunk:     array[0..32767] of byte;
 pchunk:    ^chunk;
 
 var
 BigArray:  array[0..31] of pChunk;
 

Для создания массива:


 for i := 0 to high(bigArray) do
   new(bigArray[i]);
 

Для получения доступа к n-ному байту в пределах массива (n должен иметь тип longint):


 bigArray[n shr 15]^[n and $7FFF] := y;
 x := bigArray[n shr 15]^[n and $7fff];
 

Это даже осуществляет проверку выхода за границы диапазона, если вы установили в ваших настройках опцию "range checking"!

n должен находиться в диапазоне [0..32*32*1024] = [0..1024*1024] = [0..1048576].

Для освобождения массива после его использования необходимо сделать следующее:


 for i := 0 to high(bigArray) do
   dispose (bigArray[i]);
 




Создание пустого wav-файла

Автор: Nick Hodges

Как мне создать пустой wav-файл? Это просто пустой двоичный файл?

The TMediaPlayer может открыть звуковой файл, если он содержит, по крайней мере, один байт данных. Я обнаружил это, когда с помощью данного компонента пытался создать и открыть звуковой файл, содержащий только заголовок звукового файла. The TMediaplayer не захотел этого делать.

Нижеприведенный код создаст звуковой файл размером 1 байт. Конечно это криво, но это работает. Вам необходимо лишь добавить MMSYSTEM ко всем модулям, использующим данную функцию.


 function CreateNewWave(NewFileName: string): Boolean;
 var
   DeviceID: Word;
   Return: LongInt;
   MciOpen: TMCI_Open_Parms;
   MciRecord: TMCI_Record_Parms;
   MciPlay: TMCI_Play_Parms;
   MciSave: TMCI_SaveParms;
   MCIResult: LongInt;
   Flags: Word;
   TempFileName: array[0..255] of char;
 begin
   MediaPlayer.Close;
 
   StrPCopy(TempFileName, NewFileName);
   MciOpen.lpstrDeviceType := 'waveaudio';
   MciOpen.lpstrElementName := '';
   Flags := Mci_Open_Element or Mci_Open_Type;
   MCIResult := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen));
 
   DeviceID := MciOpen.wDeviceId;
 
   MciRecord.dwTo := 1;
   Flags := Mci_To or Mci_Wait;
   MCIResult := MciSendCommand(DeviceID, Mci_Record, Flags, LongInt(@MciRecord));
 
   mciPlay.dwFrom := 0;
   Flags := Mci_From or Mci_Wait;
   MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay));
 
   mciSave.lpfileName := TempFilename;
   Flags := MCI_Save_File or Mci_Wait;
   MCIResult := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave));
 
   Result := MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil)) = 0;
 end;
 

Как мне очистить содержимое Wav-файла? Просто заново создать пустой?

Вот небольшой компонент, позволяющий стирать любую часть wave-файла:


 unit Nickmp;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, MPlayer, MMSystem;
 
 type
   TNickMediaPlayer = class(TMediaPlayer)
   private
     { Private declarations }
   protected
     { Protected declarations }
   public
     { Public declarations }
     function DeleteWaveChunk(aFrom, aTo: LongInt): Longint;
   published
     { Published declarations }
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TNickMediaPlayer]);
 end;
 
 function TNickMediaPlayer.DeleteWaveChunk(aFrom, aTo: LongInt): Longint;
 var
   DeleteParms: TMCI_WAVE_DELETE_PARMS;
   Flags: LongInt;
 begin
   Flags := 0;
 
   if Wait then
     Flags := mci_Wait;
   if Notify then
     Flags := Flags or mci_Notify;
   DeleteParms.dwCallback := Handle;
   Flags := Flags or mci_From;
   DeleteParms.dwFrom := aFrom;
   Flags := Flags or mci_To;
   DeleteParms.dwTo := aTo;
   Result := mciSendCommand(DeviceID, mci_Delete, Flags, Longint(@DeleteParms));
 end;
 
 end.
 




Создаём заблокированный файл

Автор: Christian Cristofori

Есть как минимум два способа сделать это, но один из них, при помощи Windows API (LockFileEx и UnlockFileEx) используя параметр LOCKFILE_EXCLUSIVE_LOCK не очень хорош на мой взгляд.

Поэтому предлагаю другой способ, путём создания файла при помощи функции OpenFile:


 hMyLockedFile := OpenFile( 'c:\DelphiWorld.dat', ofStruct,
 OF_CREATE or OF_READWRITE or OF_SHARE_EXCLUSIVE );
 

Теперь Вы можете работать с файлом, но пользователи уже не смогут изменить его!




Создание CGI счётчика в Delphi


Когда нормальный человек, уезжая из дома одевает на жену пояс верности, веб-дизайнер ставит на нее счетчик...

Если Вы программируете в Delphi и, хотели бы, чтобы Ваш любимый компилятор поучавствовал в создании Вашей веб-странички, то можно начать с маленькой, но довольно важной части веб-проекта - счётчика. Обычно, счётчик выглядит как кнопка на странице. В данном случае это JPEG картинка, генерируемая на лету.

Те, кто желает сразу приступить к компиляции, могут скачать исходник и, в случае возникновения каких либо вопросов, вернуться к данной статье.

Для начала давайте посмотрим - как этот счётчик может выглядеть:

Вызывается счётчик тэгом IMG примерно так:


 <img src="http://ww5.borland.com/ scripts/CounterCGI.exe?FileName=Article">
 

CGI скрипт так же может получать определённый набор параметров:

  • Txt e.g. "You are visitor %d today, and %d ever."
  • FontName e.g. "Courier"
  • FontColor e.g. "clGreen" or "$404040"
  • BackgroundColor e.g. "clYellow" or "$808080"

А вот так выглядит вызов скрипта с несколькими параметрами:


 http://ww5.borland.com/scripts/CounterCGI.exe?FileName=Article&BackgroundColor=$808080&FontColor=$404040&FontName=Courier
 

Итак, давайте разбираться с кодом.

Начать создавать новое CGI приложение следует с выбора File | New | Web Server Application | CGI stand-alone executable. После этого Вы получите чистый Web модуль. Добавьте новый TWebActionItem в подсвеченном свойстве действий (Actions) в TWebModule, нажав на Add Item. Затем двойным щелчком на событие OnAction создайте обработчик действия.

Изображение JPEG, получается как снимок изображения с TPanel, с TMemo внитри него. Таким способом легче придать 3D вид счётчику. Для начала нам необходимо добавить следующую строку в раздел implementation:


 implementation
 
 uses
   ExtCtrls, StdCtrls, Controls, Forms, Graphics, JPEG;
 

Теперь, мы определим некоторые основные процедуры, которые будут использоваться в коде. GetPaths будет обеспечивать нас двумя жизненно важными путями. Первый путь будет указывать где хранится сам скрипт по отношению к корневой директории web сервера (т.е. относительный путь). Скорее всего это будет "scripts" или "cgi-bin" в зависимости от того, куда Вы его положите. Второй - это локальный путь в Windows. Он может выглядеть как "C:\InetPub". Для нас важны оба пути, чтобы обеспечить переносимость CGI скрипта из директории в директорию и с одного сервера на другой.


 procedure GetPaths(Request: TWebRequest; var ScriptPath, LocalPath: string);
 var
   ScriptFileName: string;
 begin
   ScriptPath := Request.ScriptName;
   ScriptFileName := ExtractFileName(ParamStr(0));
   // Убираем EXE/DLL имя, чтобы получить путь
   Delete(ScriptPath, Pos(ScriptFileName, ScriptPath) - 1, Length(ScriptFileName) + 1);
   // Убираем главную косую
   Delete(ScriptPath,1,1);
 
   LocalPath := ExtractFilePath(ParamStr(0));
   // Удаление ScriptPath даёт нам корневой путь
   Delete(LocalPath, Pos(ScriptPath, LocalPath) - 1, Length(ScriptPath) + 1);
 end;
 

Процедура SetVariable будет использоваться для инициализации нужных нам переменных.


 procedure SetVariable(var S : string; const Value, default: string);
 begin
   S := Value;
   if S = '' then
     S := default;
 end;
 

Вся суть CGI скрипта заключается в событие OnAction. Давайте рассмотрим его по шагам.


 procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
 Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
 

Сперва объявим некоторые локальные переменные.


 var
   ScriptPath, LocalPath, FileName, Txt, FontColor,
   BackgroundColor, FontName, FontSize: string;
   Today, LastEver, Ever, LastToday: Integer;
   LastDate: TDate;
   MS: TMemoryStream;
   Panel: TPanel;
   Memo: TMemo;
   Bitmap: TBitmap;
   Form: TForm;
   fp: TextFile;
 

Теперь вызовем GetPaths, чтобы выяснить путь к скрипту, а так же локальный путь. В данном примере мы будем помещать наши счётчики в директорию "counters". Физический путь будет выглядеть примерно так "C:\InetPub\counters".


 begin
   GetPaths(Request, ScriptPath, LocalPath);
   LocalPath := LocalPath + 'counters\';
 

Затем, мы получаем все параметры, переданные вместе с вызовом скрипта. Параметры поступают к нам через свойство Request.QueryFields. Обратите внимание, что если какой-то параметр не был передан, то SetVariable устанавливает его по умолчанию.


 with Request.QueryFields do
 begin
   FileName := LocalPath+Values['FileName']+'.txt';
   SetVariable(Txt,Values['Txt'],'You are visitor %d today, and %d ever.');
   SetVariable(FontName,Values['FontName'],'Arial');
   SetVariable(FontSize,Values['FontSize'],'10');
   SetVariable(FontColor,Values['FontColor'],'clWhite');
   SetVariable(BackgroundColor,Values['BackgroundColor'],'clBlack');
 end;
 

Теперь мы должны быть уверены, что присутствует файл для данного счётчика. Если его нет, то просто создаём его.


 try
   // Write a new empty counter file if it doesn't exist
   if not FileExists(FileName) then
   begin
     AssignFile(fp, FileName);
     Rewrite(fp);
     WriteLn(fp, 0);
     WriteLn(fp, Date);
     WriteLn(fp, 0);
     CloseFile(fp);
   end;
 

Итак, файл существует. Естевственно, если мы создали его, что счётчик будет равен 0, иначе будем считывать старые значения, и зменять их, если необходимо. Обратите внимание , на то, как мы отслеживаем общее число посещение и посещений за день.


 // Читаем старые значения счётчика
 AssignFile(fp,FileName);
 Reset(fp);
 ReadLn(fp,LastEver);
 Ever := LastEver+1;
 ReadLn(fp,LastDate);
 ReadLn(fp,LastToday);
 if Date = LastDate then
   Today := LastToday+1
 else
   Today := 1;
 CloseFile(fp);
 

И в заключении, надо записать новые значения в файл, содержащий данные счётчика.


 // Записываем новые значения счётчика
 AssignFile(fp, FileName);
 Rewrite(fp);
 WriteLn(fp, Ever);
 WriteLn(fp, Date);
 WriteLn(fp, Today);
 CloseFile(fp);
 

Теперь приступим к созднию того, что в конечном итоге будет называться JPEG. Для начала сделаем невидимым TForm которая содержит TPanel и TMemo. Так же устанавливаем FontName и FontSize.


 Form := TForm.Create(nil);
 with Form.Font do
 begin
   name := FontName;
   Size := StrToInt(FontSize);
 end;
 

Удостоверимся в том, что текст, который мы помещаем в memo контрол, содержит значения счётчика, считанные из файла.


 Txt := Format(Txt, [Today, Ever]);
 

Далее мы создаём панель. Ширина и высота будут определяться шириной текста, который мы помещаем в неё. Так же устанавливаем скашивание для 3D эффекта.


 Panel := TPanel.Create(nil);
 with Panel do
 begin
   BevelInner := bvRaised;
   BevelOuter := bvLowered;
   Parent := Form;
   Width := Form.Canvas.TextWidth(Txt) + 9;
   Height := Form.Canvas.TextHeight(Txt) + 9;
 end;
 

Помещаем memo в панель, и устанавливаем её ширину и высоту, а так же цвет, который указан в BackgroundColor.


 Memo := TMemo.Create(nil);
 with Memo do
 begin
   Top := 2;
   Left := 2;
   Width := Panel.Width-5;
   Height := Panel.Height-5;
   Alignment := taCenter;
   Color := StringToColor(BackgroundColor);
   BorderStyle := bsNone;
   Parent := Panel;
 end;
 

Теперь необходимо сделать изображение эелемента управления, который мы создали. Для этого создаём TBitmap и закрашеваем его панелью. За одно рисуем текст на битмапе.


 Bitmap := TBitmap.Create;
 with Bitmap do
 begin
   Width := Panel.Width-1;
   Height := Panel.Height-1;
   Canvas.Lock;
   Panel.PaintTo(Canvas.Handle,0,0);
   Canvas.Unlock;
   Canvas.Brush.Style := bsClear;
   with Canvas.Font do
   begin
     name := FontName;
     Size := StrToInt(FontSize);
     Color := StringToColor(FontColor);
   end;
   Canvas.TextOut(4,3,Txt);
 end;
 

Затем преобразовываем bitmap в JPEG. JPEG будет записан в memory stream. Этот поток будет связан с браузером и передаваться посетителю странички в виде картинки.


 with Response do
 begin
   MS := TMemoryStream.Create;
   with TJPEGImage.Create do
   begin
     CompressionQuality := 75;
     Assign(Bitmap);
     SaveToStream(MS);
     Free;
   end;
   ContentType := 'image/jpeg';
   MS.Position := 0;
   SendResponse;
   SendStream(MS);
 end;
 

Освобождаем ресурсы:


 Panel.Free;
 Bitmap.Free;
 Form.Free;
 

На всякий случай обрабатываем исключительные ситуации


 except
   on E: Exception do
     Response.Content := E.message;
   end;
   Handled := True;
 end;
 

Вот собственно и всё. Наслаждайтесь счётчиком, сделанным в Delphi 5 :)




Как реализовать правильный выпадающий контрол (Combo)

Когда-то потратил немало времени на разбор, как же все таки работаю дропдаун контролы. В итоге мной был написан маленький юнит, который я положил у себя в каталоге Demo для ознакомления интерисующихся. Он маленький (его основная задача -- показать принцип работы, а все остальное -- как реализуешь), я думаю, что большинству он пригодиться, поэтому публикую здесь.


 unit edit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TPopupListbox = class(TCustomListbox)
   protected
     procedure CreateParams(var Params: TCreateParams); override;
     procedure CreateWnd; override;
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
     override;
 end;
 
 TTestDropEdit = class(TEdit)
   private
     FPickList: TPopupListbox;
     procedure CMCancelMode(var message: TCMCancelMode); message CM_CancelMode;
     procedure WMKillFocus(var message: TMessage); message WM_KillFocus;
   protected
     procedure CloseUp(Accept: Boolean);
     procedure DropDown;
     procedure WndProc(var message: TMessage); override;
   public
     constructor Create(Owner: TComponent); override;
     destructor Destroy; override;
 end;
 
 implementation
 
 procedure TPopupListBox.CreateParams(var Params: TCreateParams);
 begin
   inherited;
   with Params do
   begin
     Style := Style or WS_BORDER;
     ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST;
     WindowClass.Style := CS_SAVEBITS;
   end;
 end;
 
 procedure TPopupListbox.CreateWnd;
 begin
   inherited CreateWnd;
   Windows.SetParent(Handle, 0);
   CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
 end;
 
 procedure TPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState;
 X, Y: Integer);
 begin
   inherited MouseUp(Button, Shift, X, Y);
   TTestDropEdit(Owner).CloseUp((X >= 0) and (Y >= 0) and
   (X < Width) and (Y < Height));
 end;
 
 { TTestDropEdit }
 constructor TTestDropEdit.Create(Owner: TComponent);
 begin
   inherited Create(Owner);
   Parent := Owner as TWinControl;
   FPickList := TPopupListbox.Create(nil);
   FPickList.Visible := False;
   FPickList.Parent := Self;
   FPickList.IntegralHeight := True;
   FPickList.ItemHeight := 11;
   FPickList.Items.CommaText :='1,2,3,4,5,6,7,8,9,0';
 end;
 
 destructor TTestDropEdit.Destroy;
 begin
   FPickList.Free;
   inherited;
 end;
 
 procedure TTestDropEdit.CloseUp(Accept: Boolean);
 begin
   if FPickList.Visible then
   begin
     if GetCapture <> 0 then
       SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
     SetWindowPos(FPickList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
     SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
     if FPickList.ItemIndex <> -1 then
       Text := FPickList.Items.Strings[FPickList.ItemIndex];
     FPickList.Visible := False;
     Invalidate;
   end;
 end;
 
 procedure TTestDropEdit.DropDown;
 var
   P: TPoint;
   I,J,Y: Integer;
 begin
   if Assigned(FPickList) and (not FPickList.Visible) then
   begin
     FPickList.Width := Width;
     FPickList.Color := Color;
     FPickList.Font := Font;
     FPickList.Height := 6 * FPickList.ItemHeight + 4;
     FPickList.ItemIndex := FPickList.Items.IndexOf(Text);
     P := Parent.ClientToScreen(Point(Left, Top));
     Y := P.Y + Height;
     if Y + FPickList.Height > Screen.Height then
       Y := P.Y - FPickList.Height;
     SetWindowPos(FPickList.Handle, HWND_TOP, P.X, Y, 0, 0,
     SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
     FPickList.Visible := True;
     Invalidate;
     Windows.SetFocus(Handle);
   end;
 end;
 
 procedure TTestDropEdit.CMCancelMode(var message: TCMCancelMode);
 begin
   if (message.Sender <> Self) and (message.Sender <> FPickList) then
     CloseUp(False);
 end;
 
 procedure TTestDropEdit.WMKillFocus(var message: TMessage);
 begin
   inherited;
   CloseUp(False);
 end;
 
 procedure TTestDropEdit.WndProc(var message: TMessage);
 
   procedure DoDropDownKeys(var Key: Word; Shift: TShiftState);
   begin
     case Key of
       VK_UP, VK_DOWN:
         if ssAlt in Shift then
         begin
           if FPickList.Visible then
             CloseUp(True)
           else
             DropDown;
           Key := 0;
         end;
       VK_RETURN, VK_ESCAPE:
         if FPickList.Visible and not (ssAlt in Shift) then
         begin
           CloseUp(Key = VK_RETURN);
           Key := 0;
         end;
     end;
   end;
 
 begin
   case message.Msg of
     WM_KeyDown, WM_SysKeyDown, WM_Char:
       with TWMKey(message) do
       begin
         DoDropDownKeys(CharCode, KeyDataToShiftState(KeyData));
         if (CharCode <> 0) and FPickList.Visible then
         begin
           with TMessage(message) do
             SendMessage(FPickList.Handle, Msg, WParam, LParam);
           Exit;
         end;
       end
   end;
   inherited;
 end;
 
 end.
 




Создать компонент любого класса



 unit InfoForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
   Dbctrls, Dbgrids, Dblookup, Dbtables, Ddeman, Dialogs,
   Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
   Olectrls, Outline, Tabnotbk, Tabs, ExtDlgs, CheckLst, ToolWin;
 
 type
   TForm1 = class(TForm)
     Panel1: TPanel;
     ComboBox1: TComboBox;
     Label1: TLabel;
     Label2: TLabel;
     ComboBox2: TComboBox;
     procedure FormCreate(Sender: TObject);
     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
   private
     function GetNextName (MyClass: TComponentClass): string;
     procedure UpdateList;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 type
   TClassArray = array [1..133] of TPersistentClass;
 // definition temporary used to check the data types
 // TClassArray = array [1..133] of TComponentClass;
 const
   ClassArray: TClassArray = (
 TApplication,
 TBatchMove,
 TColorDialog,
 TFindDialog,
 TReplaceDialog,
 TFontDialog,
 TOpenDialog ,
 TOpenPictureDialog,
 TSavePictureDialog,
 TSaveDialog,
 TPrintDialog,
 TPrinterSetupDialog,
 TBevel,
 TCustomLabel,
 TDBText,
 TLabel,
 TImage,
 TPaintBox,
 TShape,
 TSpeedButton,
 TSplitter,
 TToolButton,
 TAnimate,
 TButton,
 TBitBtn,
 TCheckBox,
 TDBCheckBox,
 TRadioButton,
 TComboBox,
 TDBComboBox,
 TDriveComboBox,
 TFilterComboBox,
 TCustomDBGrid,
 TDBGrid,
 TDBLookupList,
 TPopupGrid,
 TOutline,
 TDrawGrid,
 TStringGrid,
 TDBRadioGroup,
 TRadioGroup,
 TGroupBox,
 TDBNavigator,
 TPanel,
 TDBImage,
 TDBLookupControl,
 TDBLookupComboBox,
 TDBLookupListBox,
 TPopupDataList,
 THeader,
 THintWindow,
 TMediaPlayer,
 TNotebook,
 TOleContainer,
 TPage,
 TScroller,
 TTabSet,
 TDBEdit,
 TInplaceEdit,
 TMaskEdit,
 TCustomRichEdit,
 TDBRichEdit,
 TRichEdit,
 TDBMemo,
 TMemo,
 TDBLookupCombo,
 TEdit,
 THotKey,
 TCheckListBox,
 TDBListBox,
 TDirectoryListBox,
 TFileListBox,
 TListBox,
 TListView,
 TStaticText,
 TPageControl,
 TTabbedNotebook,
 TTabControl,
 TTreeView,
 TUpDown,
 TDateTimePicker,
 TDBCtrlGrid,
 TDBCtrlPanel,
 THeaderControl,
 TOleControl,
 TProgressBar,
 TScrollBar,
 TScrollBox,
 TStatusBar,
 TTabPage,
 TTabSheet,
 TToolWindow,
 TCoolBar,
 TToolBar,
 TTrackBar,
 TImageList,
 TDatabase,
 TDataModule,
 TQuery,
 TStoredProc,
 TTable,
 TUpdateSQL,
 TDataSource,
 TDdeClientConv,
 TDdeClientItem,
 TDdeMgr,
 TDdeServerConv,
 TDdeServerItem,
 TBinaryField,
 TBytesField,
 TVarBytesField,
 TBlobField,
 TGraphicField,
 TMemoField,
 TBooleanField,
 TDateTimeField,
 TDateField,
 TTimeField,
 TNumericField,
 TBCDField,
 TFloatField,
 TCurrencyField,
 TIntegerField,
 TAutoIncField,
 TSmallintField,
 TWordField,
 TStringField,
 TMainMenu,
 TPopupMenu,
 TMenuItem,
 TScreen,
 TSession,
 TTimer
 );
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   I: Integer;
 begin
   // register all of the classes
   RegisterClasses (ClassArray);
   // copy class names to the listbox
   for I := Low (ClassArray) to High (ClassArray) do
     ComboBox1.Items.Add (ClassArray [I].ClassName);
   UpdateList;
 end;
 
 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 var
   MyClass: TComponentClass;
   MyComp: TComponent;
 begin
   MyClass := TComponentClass (GetClass (ComboBox1.Text));
   if MyClass = nil then
     Beep
   else
   begin
     MyComp := MyClass.Create (self);
     MyComp.Name := GetNextName (MyClass);
     if MyClass.InheritsFrom (TControl) then
     // if MyComp is TControl then  // alternative version
     begin
       TControl (MyComp).Left := X;
       TControl (MyComp).Top := Y;
       TControl (MyComp).Parent := self;
     end;
   end;
   UpdateList;
 end;
 
 function TForm1.GetNextName (MyClass: TComponentClass): string;
 var
   I, nTot: Integer;
 begin
   nTot := 0;
   for I := 0 to ComponentCount - 1 do
     if Components [I].ClassType = MyClass then
       Inc (nTot);
   Result := Copy (MyClass.ClassName, 2, Length (MyClass.ClassName) - 1) +
     IntToStr (nTot);
 end;
 
 procedure TForm1.UpdateList;
 var
   I: Integer;
 begin
   Combobox2.Items.Clear;
   for I := 0 to ComponentCount - 1 do
     ComboBox2.Items.Add (Components [I].Name);
 end;
 
 end.

Загрузить весь проект




Создание консольных приложений

Автор: Михаил Чумак

Переустановка Windows - как разморозка холодильника. Помогает, но ненадолго...

Создание консольных приложений. (Об этом в советах немножко есть, но очень не конкретно)

Как уже отмечалось в совете [000092] (да и в Хелпе) в консольных приложениях в Delphi можно использовать в принципе весь дельфийский арсенал. Правда и работать они будут лишь под Windows. (Кстати этот способ можно применить для модернизации программ на Паскале под Windows).

Этот код был использован для вывода результатов работы программы проверки (неважно чего) чтобы не приходилось смотреть файл с результатами. Главная проблема была в том, что консоль (если запуск был из Windows) оставалась висеть позади формы до её закрытия. Вреда конечно никакого, но не приятно. Если же запуск из Нортона или т.п., то всё идёт нормально.


 program MyProgram;
 
 {$APPTYPE CONSOLE}
 
 uses
 
   Windows, Forms, Dialogs, SysUtils, StdCtrls, Controls; // и (или) т.п.
 
 ...
 
 var
   ...
   SH, SW: integer;
   MainForm: TForm; // если нужна форма
   Memo: TMemo;
   // могут быть также любые другие визуальные компоненты
   ...
 
   // здесь могут быть процедуры и функции, т.е вс? как в обычном Паскале
 
 begin
 
   ... // здесь какой-то код
 
   { а здесь, перед выводом формы, есть два пути:}
   { так}
 
   // Отцепиться от консоли, т.е она просто исчезнет (в случае запуска из Windows)
   // и останется только форма
   FreeConsole;
   { или так}
   //  Handle:= GetForegroundWindow; // Получить Handle консоли
   //  ShowWindow(Handle, SW_HIDE);  // Спрятать консоль
   // а в конце, перед завершением
   //  ShowWindow(Handle, SW_SHOW); // Показать консоль
 
   { для помещения формы в центр экрана}
   SH := Screen.Height;
   SW := Screen.Width;
 
   MainForm := TForm.Create(nil);
   with MainForm do
   try
     BorderStyle := bsSizeable;
     Height := 390;
     Width := 390;
     Left := (SW - Width) div 2;
     Top := (SH - Height) div 2;
     Caption := 'Моя программа';
     // здесь могут быть и другие компоненты
     Memo := TMemo.Create(MainForm);
     with Memo do
     begin
       Parent := MainForm;
       Align := alClient;
       BorderStyle := bsNone;
       Font.Name := 'Courier New Cyr';
       Font.Size := 9;
       ScrollBars := ssVertical;
       Lines.LoadFromFile('MyProgram.txt');
     end;
     ShowModal;
   finally
     Free;
   end;
 
   { или можно вывести сообщение, например в случае неудачи (или наоборот)}
 
   with CreateMessageDialog('Текст сообщения', mtInformation, [mbOk]) do
   try
     Caption := 'Заголовок';
     ShowModal;
   finally
     Free;
   end;
 
   ...
 
   //  это для второго пути, иначе она так и останется висеть св?рнутой
   //  ShowWindow(Handle, SW_SHOW); // Показать консоль
 
 end.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS