Компьютерный форум
Правила
Вернуться   Компьютерный форум > Форум программистов > Программирование под Windows
Перезагрузить страницу Delphi FAQ как сделать форму по верх всех окон
Ответ
 
Опции темы Опции просмотра
  (#1 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию Delphi FAQ как сделать форму по верх всех окон - 12.05.2006, 16:36

Q: Как сделать так, чтобы форма была поверх всех окон кроме, как через formstyle = stayontop?

A: Вместо MyForm.Show:
Код:
var
  wnd: HWND;
begin
   wnd := GetForegroundWindow;    
   MyForm.FormStyle := fsNormal;
   MyForm.Show;    
   MyForm.FormStyle := fsStayOnTop;    
   SetForegroundWindow(wnd);
end;
А по таймеру необходимо выполнять:
Код:
var
  wnd: HWND;
begin
  wnd := GetActiveWindow;
  if wnd <> Bubble.Handle then SetActiveWindow(Bubble.Handle);
end;
На случай перекрытия другими OnTop формами.
Ответить с цитированием
  (#2 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию Delphi FAQ как сделать форму по верх всех окон - 12.05.2006, 16:36

Q: Как сделать так, чтобы форма была поверх всех окон кроме, как через formstyle = stayontop?

A: Вместо MyForm.Show:
Код:
var
  wnd: HWND;
begin
   wnd := GetForegroundWindow;    
   MyForm.FormStyle := fsNormal;
   MyForm.Show;    
   MyForm.FormStyle := fsStayOnTop;    
   SetForegroundWindow(wnd);
end;
А по таймеру необходимо выполнять:
Код:
var
  wnd: HWND;
begin
  wnd := GetActiveWindow;
  if wnd <> Bubble.Handle then SetActiveWindow(Bubble.Handle);
end;
На случай перекрытия другими OnTop формами.
Ответить с цитированием
  (#3 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 17:09

Q: Как добавить в системное меню своей программы пунктик например, About) и как обрабатывать событие, когда пользователь его выбирает?

A: Добовляем пункт меню, в системное меню:
Код:
SysMenu:=GetSystemMenu(Handle,False); 
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_About, 'About');
Обробатываем вызов меню:
Код:
case Message.wParam of 
ID_About:DatBitBtnClick(Self);
Ответить с цитированием
  (#4 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 17:09

Q: Как добавить в системное меню своей программы пунктик например, About) и как обрабатывать событие, когда пользователь его выбирает?

A: Добовляем пункт меню, в системное меню:
Код:
SysMenu:=GetSystemMenu(Handle,False); 
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_About, 'About');
Обробатываем вызов меню:
Код:
case Message.wParam of 
ID_About:DatBitBtnClick(Self);
Ответить с цитированием
  (#5 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 17:32

Q: Как получить информацию о системе?

A: Структура SYSTEM_INFO содержит в себе информацию о системе компьютера. Информация включает в себя информацию об архитектуре и типе процессора, число процессоров в системе, информацию о размерах страниц а так же много другой информации. Более подробнее об этой структуре можно узнать в хэлпе или MSDN-е.

Пример использования:
Код:
var
   SysInfo: TSystemInfo;
 begin
   GetSystemInfo(SysInfo);
Ответить с цитированием
Ads.
  (#6 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 17:32

Q: Как получить информацию о системе?

A: Структура SYSTEM_INFO содержит в себе информацию о системе компьютера. Информация включает в себя информацию об архитектуре и типе процессора, число процессоров в системе, информацию о размерах страниц а так же много другой информации. Более подробнее об этой структуре можно узнать в хэлпе или MSDN-е.

Пример использования:
Код:
var
   SysInfo: TSystemInfo;
 begin
   GetSystemInfo(SysInfo);
Ответить с цитированием
  (#7 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 17:47

Q: Как организовать поиск файла (функция FindFileInTree)?

A: LPSTR FindFileInTree(LPSTR szFile, LPSTR szDir, LPSTR szBuf, int cbBuf);

FindFileInTree ищет файл в директориях и суб дерикториях.

szFile - Имя файла
szDir - Так называемая директория верхнего уравня
szBuf - Указатель на выходной буфер содержащий пути
cbBuf - Длинна в байтах этого буфера

Возвращает полный путь первого найденного файла, ежели файл не найден возвращает пустую строку.
Ответить с цитированием
  (#8 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 17:47

Q: Как организовать поиск файла (функция FindFileInTree)?

A: LPSTR FindFileInTree(LPSTR szFile, LPSTR szDir, LPSTR szBuf, int cbBuf);

FindFileInTree ищет файл в директориях и суб дерикториях.

szFile - Имя файла
szDir - Так называемая директория верхнего уравня
szBuf - Указатель на выходной буфер содержащий пути
cbBuf - Длинна в байтах этого буфера

Возвращает полный путь первого найденного файла, ежели файл не найден возвращает пустую строку.
Ответить с цитированием
  (#9 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 18:11

Q: Как программно отключить клавиатуру и мышь?

A: Вызываем функцию из DLL'ки:

procedure BlockInput(ABlockInput: boolean); stdcall; external 'USER32.DLL';

Пример использования:
Код:
procedure TForm1.N1Click(Sender: TObject);
begin
  BlockInput(True);
  // Вот собственно этим мы и блокируем клаву и мышь
  // (для обратного исхода надо вместо True написать False)
end;
Ответить с цитированием
  (#10 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 18:11

Q: Как программно отключить клавиатуру и мышь?

A: Вызываем функцию из DLL'ки:

procedure BlockInput(ABlockInput: boolean); stdcall; external 'USER32.DLL';

Пример использования:
Код:
procedure TForm1.N1Click(Sender: TObject);
begin
  BlockInput(True);
  // Вот собственно этим мы и блокируем клаву и мышь
  // (для обратного исхода надо вместо True написать False)
end;
Ответить с цитированием
  (#11 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 18:21

Q: Как заблокировать и разблокировать CD-ROM?

A:
Код:
procedure TMainForm.CD_Lock(Locked: Boolean, DriveLetter: string);
const
  IOCTL_STORAGE_MEDIA_REMOVAL = $002D4804;
var
  hDrive: THandle;
  Returned: DWORD;
  DisableEject: boolean;
begin
  hDrive := CreateFile(PChar('.' + DriveLetter), GENERIC_READ,
    FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,
    0);
  if GetLastError <> 0 then
    MessageDlg('Error:' + IntToStr(GetLastError), mtError, [mbOK], 0);
  try
    DisableEject := Locked;
    if not DeviceIoControl(hDrive,
      IOCTL_STORAGE_MEDIA_REMOVAL, // PREVENT_MEDIA_REMOVAL,
      @DisableEject,
      SizeOf(DisableEject),
      nil,
      0,
      Returned,
      nil) then
      MessageDlg('Ошибка:' + IntToStr(GetLastError), mtError, [mbOK], 0)
  finally
    CloseHandle(hDrive)
  end;
end;
CD_Lock(True) - блокирует CD-ROM
CD_Lock(False) - разблокирует CD-ROM

Для полного веселья можно заблокировать все CD-ROMы в системе через это:
Код:
procedure TMainForm.LockCDROMs;
var
  w: dword;
  Root: string;
  i: byte;
begin
  w := GetLogicalDrives;
  Root := '#:';
  for i := 0 to 25 do
  begin
    Root[1] := Char(Ord('A') + i);
    if (W and (1 shl i)) > 0 then
      if GetDriveType(PChar(Root)) = DRIVE_CDROM then
      begin
        DriveLetter := Copy(Root, 1, Length(Root) - 1);
        CD_Lock(True, DriveLetter)
      end
  end;
end;
Ответить с цитированием
  (#12 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 18:21

Q: Как заблокировать и разблокировать CD-ROM?

A:
Код:
procedure TMainForm.CD_Lock(Locked: Boolean, DriveLetter: string);
const
  IOCTL_STORAGE_MEDIA_REMOVAL = $002D4804;
var
  hDrive: THandle;
  Returned: DWORD;
  DisableEject: boolean;
begin
  hDrive := CreateFile(PChar('.' + DriveLetter), GENERIC_READ,
    FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,
    0);
  if GetLastError <> 0 then
    MessageDlg('Error:' + IntToStr(GetLastError), mtError, [mbOK], 0);
  try
    DisableEject := Locked;
    if not DeviceIoControl(hDrive,
      IOCTL_STORAGE_MEDIA_REMOVAL, // PREVENT_MEDIA_REMOVAL,
      @DisableEject,
      SizeOf(DisableEject),
      nil,
      0,
      Returned,
      nil) then
      MessageDlg('Ошибка:' + IntToStr(GetLastError), mtError, [mbOK], 0)
  finally
    CloseHandle(hDrive)
  end;
end;
CD_Lock(True) - блокирует CD-ROM
CD_Lock(False) - разблокирует CD-ROM

Для полного веселья можно заблокировать все CD-ROMы в системе через это:
Код:
procedure TMainForm.LockCDROMs;
var
  w: dword;
  Root: string;
  i: byte;
begin
  w := GetLogicalDrives;
  Root := '#:';
  for i := 0 to 25 do
  begin
    Root[1] := Char(Ord('A') + i);
    if (W and (1 shl i)) > 0 then
      if GetDriveType(PChar(Root)) = DRIVE_CDROM then
      begin
        DriveLetter := Copy(Root, 1, Length(Root) - 1);
        CD_Lock(True, DriveLetter)
      end
  end;
end;
Ответить с цитированием
Ads
  (#13 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 19:05

Q: Как сделать снимок экрана (скриншот)?

A: Делаем скриншот всей рабочей области экрана:
Код:
procedure ScreenShot(Bild: TBitMap);
 var
   c: TCanvas;
   r: TRect;
 begin
   c := TCanvas.Create;
   c.Handle := GetWindowDC(GetDesktopWindow);
   try
     r := Rect(0, 0, Screen.Width, Screen.Height);
     Bild.Width := Screen.Width;
     Bild.Height := Screen.Height;
     Bild.Canvas.CopyRect(r, c, r);
   finally
     ReleaseDC(0, c.Handle);
     c.Free;
   end;
 end;
Пример:
Код:
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Visible := False;
   Sleep(750); 
   ScreenShot(Image1.Picture.BitMap);
   Form1.Visible := True;
 end;
Делаем скриншот активного окна:
Код:
procedure ScreenShotActiveWindow(Bild: TBitMap);
 var
   c: TCanvas;
   r, t: TRect;
   h: THandle;
 begin
   c := TCanvas.Create;
   c.Handle := GetWindowDC(GetDesktopWindow);
   h := GetForeGroundWindow;
   if h <> 0 then
     GetWindowRect(h, t);
   try
     r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
     Bild.Width  := t.Right - t.Left;
     Bild.Height := t.Bottom - t.Top;
     Bild.Canvas.CopyRect(r, c, t);
   finally
     ReleaseDC(0, c.Handle);
     c.Free;
   end;
 end;
Пример:
Код:
procedure TForm1.Button2Click(Sender: TObject);
begin
  Form1.Visible := False;
  Sleep(750);  
  ScreenShotActiveWindow(Image1.Picture.BitMap);
  Form1.Visible := True;
end;
Делаем скриншот выбранной области:
Код:
procedure ScreenShot(x: Integer;
   y: Integer; 
   Width: Integer;
   Height: Integer; 
  bm: TBitMap);  
var
   dc: HDC;
   lpPal: PLOGPALETTE;
 begin
   if ((Width = 0) or
     (Height = 0)) then
     Exit;
   bm.Width  := Width;
   bm.Height := Height;
   {get the screen dc}
   dc := GetDc(0);
   if (dc = 0) then
     Exit;
   {do we have a palette device?}
   if (GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE) then
   begin
     {allocate memory for a logical palette}
     GetMem(lpPal,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
     {zero it out to be neat}
     FillChar(lpPal^,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)),
       #0);
     {fill in the palette version}
     lpPal^.palVersion := $300;
     {grab the system palette entries}
     lpPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       lpPal^.palPalEntry);
     if (lpPal^.PalNumEntries <> 0) then
       {create the palette}
       bm.Palette := CreatePalette(lpPal^);
     FreeMem(lpPal, SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the bitmap}
   BitBlt(bm.Canvas.Handle,
     0,
     0,
     Width,
     Height,
     Dc,
     x,
     y,
     SRCCOPY);
   {release the screen dc}
   ReleaseDc(0, dc);
 end;
Пример:
Код:
procedure TForm1.Button1Click(Sender: TObject);
begin
 ScreenShot(0,0,Screen.Width, Screen.Height, Image1.Picture.Bitmap);
end;
Скриншот любого окна:
Код:
procedure ScreenShot(hWindow: HWND; bm: TBitmap);
 var
   Left, Top, Width, Height: Word;
   R: TRect;
   dc: HDC;
   lpPal: PLOGPALETTE;
 begin
   {Check if valid window handle}
   if not IsWindow(hWindow) then Exit;
   {Retrieves the rectangular coordinates of the specified window}
   GetWindowRect(hWindow, R);
   Left := R.Left;
   Top := R.Top;
   Width := R.Right - R.Left;
   Height := R.Bottom - R.Top;
   bm.Width  := Width;
   bm.Height := Height;
   {get the screen dc}
   dc := GetDc(0);
   if (dc = 0) then
    begin
     Exit;
   end;
   {do we have a palette device?}
   if (GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE) then
    begin
     {allocate memory for a logical palette}
     GetMem(lpPal,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
     {zero it out to be neat}
     FillChar(lpPal^,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)),
       #0);
     {fill in the palette version}
     lpPal^.palVersion := $300;
     {grab the system palette entries}
     lpPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       lpPal^.palPalEntry);
     if (lpPal^.PalNumEntries <> 0) then
      begin
       {create the palette}
       bm.Palette := CreatePalette(lpPal^);
     end;
     FreeMem(lpPal, SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the bitmap}
   BitBlt(bm.Canvas.Handle,
     0,
     0,
     Width,
     Height,
     Dc,
     Left,
     Top,
     SRCCOPY);
   {release the screen dc}
   ReleaseDc(0, dc);
 end;
Пример:
Код:
procedure TForm1.Button1Click(Sender: TObject);
 begin
   ScreenShot(GetForeGroundWindow, Image1.Picture.Bitmap);
 end;
Ответить с цитированием
  (#14 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 12.05.2006, 19:05

Q: Как сделать снимок экрана (скриншот)?

A: Делаем скриншот всей рабочей области экрана:
Код:
procedure ScreenShot(Bild: TBitMap);
 var
   c: TCanvas;
   r: TRect;
 begin
   c := TCanvas.Create;
   c.Handle := GetWindowDC(GetDesktopWindow);
   try
     r := Rect(0, 0, Screen.Width, Screen.Height);
     Bild.Width := Screen.Width;
     Bild.Height := Screen.Height;
     Bild.Canvas.CopyRect(r, c, r);
   finally
     ReleaseDC(0, c.Handle);
     c.Free;
   end;
 end;
Пример:
Код:
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Visible := False;
   Sleep(750); 
   ScreenShot(Image1.Picture.BitMap);
   Form1.Visible := True;
 end;
Делаем скриншот активного окна:
Код:
procedure ScreenShotActiveWindow(Bild: TBitMap);
 var
   c: TCanvas;
   r, t: TRect;
   h: THandle;
 begin
   c := TCanvas.Create;
   c.Handle := GetWindowDC(GetDesktopWindow);
   h := GetForeGroundWindow;
   if h <> 0 then
     GetWindowRect(h, t);
   try
     r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
     Bild.Width  := t.Right - t.Left;
     Bild.Height := t.Bottom - t.Top;
     Bild.Canvas.CopyRect(r, c, t);
   finally
     ReleaseDC(0, c.Handle);
     c.Free;
   end;
 end;
Пример:
Код:
procedure TForm1.Button2Click(Sender: TObject);
begin
  Form1.Visible := False;
  Sleep(750);  
  ScreenShotActiveWindow(Image1.Picture.BitMap);
  Form1.Visible := True;
end;
Делаем скриншот выбранной области:
Код:
procedure ScreenShot(x: Integer;
   y: Integer; 
   Width: Integer;
   Height: Integer; 
  bm: TBitMap);  
var
   dc: HDC;
   lpPal: PLOGPALETTE;
 begin
   if ((Width = 0) or
     (Height = 0)) then
     Exit;
   bm.Width  := Width;
   bm.Height := Height;
   {get the screen dc}
   dc := GetDc(0);
   if (dc = 0) then
     Exit;
   {do we have a palette device?}
   if (GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE) then
   begin
     {allocate memory for a logical palette}
     GetMem(lpPal,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
     {zero it out to be neat}
     FillChar(lpPal^,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)),
       #0);
     {fill in the palette version}
     lpPal^.palVersion := $300;
     {grab the system palette entries}
     lpPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       lpPal^.palPalEntry);
     if (lpPal^.PalNumEntries <> 0) then
       {create the palette}
       bm.Palette := CreatePalette(lpPal^);
     FreeMem(lpPal, SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the bitmap}
   BitBlt(bm.Canvas.Handle,
     0,
     0,
     Width,
     Height,
     Dc,
     x,
     y,
     SRCCOPY);
   {release the screen dc}
   ReleaseDc(0, dc);
 end;
Пример:
Код:
procedure TForm1.Button1Click(Sender: TObject);
begin
 ScreenShot(0,0,Screen.Width, Screen.Height, Image1.Picture.Bitmap);
end;
Скриншот любого окна:
Код:
procedure ScreenShot(hWindow: HWND; bm: TBitmap);
 var
   Left, Top, Width, Height: Word;
   R: TRect;
   dc: HDC;
   lpPal: PLOGPALETTE;
 begin
   {Check if valid window handle}
   if not IsWindow(hWindow) then Exit;
   {Retrieves the rectangular coordinates of the specified window}
   GetWindowRect(hWindow, R);
   Left := R.Left;
   Top := R.Top;
   Width := R.Right - R.Left;
   Height := R.Bottom - R.Top;
   bm.Width  := Width;
   bm.Height := Height;
   {get the screen dc}
   dc := GetDc(0);
   if (dc = 0) then
    begin
     Exit;
   end;
   {do we have a palette device?}
   if (GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE) then
    begin
     {allocate memory for a logical palette}
     GetMem(lpPal,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
     {zero it out to be neat}
     FillChar(lpPal^,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)),
       #0);
     {fill in the palette version}
     lpPal^.palVersion := $300;
     {grab the system palette entries}
     lpPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       lpPal^.palPalEntry);
     if (lpPal^.PalNumEntries <> 0) then
      begin
       {create the palette}
       bm.Palette := CreatePalette(lpPal^);
     end;
     FreeMem(lpPal, SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the bitmap}
   BitBlt(bm.Canvas.Handle,
     0,
     0,
     Width,
     Height,
     Dc,
     Left,
     Top,
     SRCCOPY);
   {release the screen dc}
   ReleaseDc(0, dc);
 end;
Пример:
Код:
procedure TForm1.Button1Click(Sender: TObject);
 begin
   ScreenShot(GetForeGroundWindow, Image1.Picture.Bitmap);
 end;
Ответить с цитированием
  (#15 (permalink)) Старый
SH@DOW SH@DOW вне форума
Member
 
Сообщений: 2,085
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 18.09.2002
По умолчанию 16.05.2006, 12:34

Q: Как скопировать папку с подпапками и файлами в другое место?

A: Фукция копирует СОДЕРЖИМОЕ директории SourceDir в директорию TargetDir.
Копируются все файлы, подкаталоги, и файлы находящиеся в этих подкаталогах.

Аргумент StopIfNotAllCopied: если значение этого аргумента = True,
то при первой же ошибке копирования файла или папки, работы функции прекратится а функуция вернёт False. В случае если этот аргумент = False, то ошибки копирования учитываться не будут.
Код:
function FullDirectoryCopy(SourceDir, TargetDir: string; StopIfNotAllCopied,
  OverWriteFiles: Boolean): Boolean;
var
  SR: TSearchRec;
  I: Integer;
begin
  Result := False;
  SourceDir := IncludeTrailingBackslash(SourceDir);
  TargetDir := IncludeTrailingBackslash(TargetDir);
  if not DirectoryExists(SourceDir) then
    Exit;
  if not ForceDirectories(TargetDir) then
    Exit;

  I := FindFirst(SourceDir + '*', faAnyFile, SR);
  try
    while I = 0 do
    begin
      if (SR.Name <> '') and (SR.Name <> '.') and (SR.Name <> '..') then
      begin
        if SR.Attr = faDirectory then
          Result := FullDirectoryCopy(SourceDir + SR.Name, TargetDir + SR.NAME,
            StopIfNotAllCopied, OverWriteFiles)
        else if not (not OverWriteFiles and FileExists(TargetDir + SR.Name))
          then
          Result := CopyFile(Pchar(SourceDir + SR.Name), Pchar(TargetDir +
            SR.Name), False)
        else
          Result := True;
        if not Result and StopIfNotAllCopied then
          exit;
      end;
      I := FindNext(SR);
    end;
  finally
    SysUtils.FindClose(SR);
  end;
end;
Ответить с цитированием
Ответ

Опции темы
Опции просмотра

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.
Trackbacks are Вкл.
Pingbacks are Вкл.
Refbacks are Выкл.


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Форма по верх всех окон, даже по верх игр Spark-Team Visual Basic 1 16.10.2007 16:44
Форма по верх всех окон Spark-Team Visual Basic 1 28.09.2007 13:29
Вывод текста поверх всех окон WildRain Visual Basic 2 11.10.2006 14:45
Как сделать программу поверх всех окон vikaz C++ Builder 2 17.05.2006 18:06
Как сделать программу поверх всех окон Ghostep Delphi 4 05.05.2006 16:08
Как вывести текст поверх всех окон в в том числе в играх? DVD Visual C++ 3 29.08.2005 13:04
Как сделать программу поверх всех окон Bars-Master WinAPI 8 24.06.2005 10:39
Как вывести сообщение поверх всех окон VIB Delphi 3 10.08.2004 14:30
Открытие программы поверх всех окон anzor C++ Builder 2 25.07.2004 02:08
Как сделать программу поверх всех окон GEV_256 Delphi 3 08.06.2003 16:54
Как из Visual С получить список всех дескрипторов отрытых окон Anonymous Visual C++ 1 27.02.2003 02:30
Создание дочерней формы в модальном режиме поверх всех окон gray_k C++ Builder 7 17.11.2002 21:40



Powered by vBulletin® Version 3.8.7
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Нardforum.ru - компьютерный форум и программирование, форум программистов