VPF::Начался отбор тем для DRKB 3.0 - Форум программистов

Rouse_

Дата 27.9.2006, 22:15 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005

Репутация: 5
Всего: 29

Итак, Виталий Невзоров открывает следующий этап расширения Delphi Russian Knowledge Base .
Что есть DRKB: это самая большая и полная в рунете база знаний по Дельфи, составленная по материалам форумов Vingrad.ru и Sources.ru, а так же других источников. Содержит более 2000 хорошо отклассифицированных и тщательно оформленных статей в формате chm (Windows Help).
Эта база составленна силами профессиональных программистов (и им сочуствующим) для программистов .
Если вы желаете расширить эту базу своим материалом и стать совтором DRKB, то отправляйте Ваши материалы в данную ветку.
Добавление статьи в данную ветку происходит на Вашей доброжелательной основе.
Ваши материалы не рецензируются, но могут редактироваться.
Все статьи будут тщательно анализироваться сообществом модераторов форума и привлеченных извне специалистов по тематике статьи.
Статьи, помещеные в DRKB, обязательно будут иметь указание на автора статьи.
Большая просьба: не пишите по поводу непомещения Вашей статьи в DRKB.
Если она не помещена в DRKB - значит она не прошла проверку на качество подачи материала или уровень изложения.
(Объяснения причин отсутствия статьи не разглашаются)

M
Snowy

Все материалы или линки на них бросаем прямо в этот топ.
(На случай, если кто прочитал, но не заметил)

--------------------

Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru

Voyager

Дата 28.9.2006, 19:26 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 532
Регистрация: 8.2.2005

Репутация: 2
Всего: 18

Вот может что приглянется:

Скриншот средствами WinAPI:
http://forum.vingrad.ru/index.php?showtopi...st&p=540249
Минимальное приложение на WinAPI (для новичков с подробностями):
http://voyager.alfamoon.com/forum/topic.ph...m=3&topic=1
Ping средствами ICMP API:
http://voyager.alfamoon.com/forum/topic.ph...m=3&topic=3
Системы счисления. Перевод из десятичной в любую другую:
http://voyager.alfamoon.com/forum/topic.ph...=3&topic=30

Update (чтобы не флудить):

Цитата

Разве этого нет в ДРКБ?

Описание ICMP в DRKB видел (но у меня просто полный пример приложения с объяснениями), остальное не видел (про API в DRKB вообще мало), статью "Минимальное приложение на WinAPI" писал сам лично, "Скриншот средствами WinAPI" в DRKB нет, такого метода как в "Перевод из десятичной в любую другую" в DRKB тоже нет.

Это сообщение отредактировал(а) Voyager - 29.9.2006, 16:01

Vit

Дата 28.9.2006, 22:25 (ссылка)

(нет голосов)

Загрузка ...

Vitaly Nevzorov

Профиль
Группа: Экс. модератор
Сообщений: 10964
Регистрация: 25.3.2002
Где: Chicago

Репутация: 48
Всего: 207

Цитата(Voyager @ 28.9.2006, 10:26

)

Скриншот средствами WinAPI:
http://forum.vingrad.ru/index.php?showtopi...st&p=540249
Минимальное приложение на WinAPI (для новичков с подробностями):
http://voyager.alfamoon.com/forum/topic.ph...m=3&topic=1
Ping средствами ICMP API:
http://voyager.alfamoon.com/forum/topic.ph...m=3&topic=3
Системы счисления. Перевод из десятичной в любую другую:
http://voyager.alfamoon.com/forum/topic.ph...=3&topic=30

Разве этого нет в ДРКБ?

--------------------

With the best wishes, Vit
I have done so much with so little for so long that I am now qualified to do anything with nothing
Самый большой Delphi FAQ на русском языке здесь: www.drkb.ru

Snowy

Дата 28.9.2006, 23:23 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 192
Всего: 484

Virtual Treeview (статья by Quadr0)

Как определить, что программа запущена в терминальном режиме
Решение простое, но может пригодиться smile

Управление Планировщиком задач Windows
Решение конечно не претендует на 100% полноценность, но лучше, чем ничего. Дорабатывать до полнофункционала очень лениво. Но, кому надо, дальше сам разберётся.

Скачать файл по https
Ну уж очень регулярный вопрос. Решение не сложное - вопрос частый.

Блокировка лотка CD-ROM
В DRKB есть, но там на плюсах. Эта на Delphi.

Получить версию Windows
Не убивайте smile

Этот вариант оптеделяет более детально, в отличие от 4-х способов DRKB.

Определить, какая версия WinRAR требуется для распаковки rar архива
Не знаю, насколько нужный код. Но он маленький - много места не займёт - смотрите сами, нужен или нет.

Alexeis

Дата 29.9.2006, 00:51 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459

Цитата(Snowy @ 28.9.2006, 23:23

)

Блокировка лотка CD-ROM
В DRKB есть, но там на плюсах. Эта на Delphi.

Вдобавок к CDROM я выкладываю блокировку Флопика

Код


 var
  h : THandle;

begin
  h := CreateFile ('\\.\A:',
                   GENERIC_READ or GENERIC_WRITE,
                   0,
                   nil,
                   OPEN_EXISTING,
                   FILE_ATTRIBUTE_NORMAL,
                   0);
end;
Разблокировка:
CloseHandle(h);

Вот еще процедурка напианая Snowy (вдруг он про нее забыл smile

) для очистки содержимого файла без возможности восстановления, по методу Гуттмана.

Код


procedure ZeroFillDelete(FileName: string);    
var    
  fs: TFileStream;    
  i:  integer;    
  procedure RandomWrite;    
  var b:  byte;    
  begin    
    repeat    
      b := Random(256); fs.Write(b, 1);    
    until fs.Position + 1 >= fs.Size;    
  end;    
  procedure WritePattern(pattern: byte);    
  const patt: array[5..31] of dword = ($555555, $AAAAAA, $924924, $492492,    
        $249249, 0, $111111, $222222, $333333, $444444, $555555, $666666,    
        $777777, $888888, $999999, $AAAAAA, $BBBBBB, $CCCCCC, $DDDDDD,    
        $EEEEEE, $FFFFFF, $924924, $492492, $249249, $6DB6DB, $B6DB6D, $DB6DB6);    
  var d: dword;    
  begin    
    d := patt[pattern] shl 8;    
    repeat fs.Write(d, 3); until fs.Position + 3 >= fs.Size;    
  end;    
begin    
  if not FileExists(FileName) then Exit;    
  for i := 1 to 35 do    
  try    
    fs := TFileStream.Create(FileName, fmOpenWrite);    
    try    
      if (i < 5) or (i > 31) then RandomWrite    
      else WritePattern(i);    
    finally    
      fs.Free;    
    end;    
  except Exit; end;    
  DeleteFile(FileName);    
end;

Добавлено @ 00:59
От меня лично
Про работу с Wave файлами (в drkb пример не соответствует спецификации стандарта)
http://forum.vingrad.ru/index.php?showtopic=89826&hl=

И про BMP файлы (полный разбор структуры, всех разновидностей + пример в котором задействованы всевозможные форматы)
http://forum.vingrad.ru/index.php?showtopi...%BC%D0%B0%D1%82

Добавлено @ 01:04
Вот еще пример загрузки того же битмапа ввиде DIB но уже при помощи функций API (переработаный и исправленный вариант из DelpiWord)

Код


type
  Trgb = packed record
                 b,g,r : byte
                 end;

  arr = array[1..250,1..200] of Trgb;

procedure TForm1.Button1Click(Sender: TObject);
var
 DC : hDC;
 Bitmap : HBITMAP;
 p : ^arr;        //можно удалить
 i, j : integer;  //можно удалить
 bmInfo: TDIBSection;           // структура BITMAP WinAPI
 W, H : Integer;                 // высота и ширина растра
 bmDIB: hBitmap;                // дискрептор независимого растра
 bmiInfo: BITMAPINFO;           // структура BITMAPINFO WinAPI
 lpBits: PRGBTriple;            // указатели на структуры RGBTRIPLE WinAPI

begin
  DC := Form1.Canvas.Handle; {DC := GetDC(Handle)
                              Handle - окна вывода(или любого)}

  Bitmap := LoadImage(0,
      'IMG.bmp',
      IMAGE_BITMAP,
      0,
      0,
      LR_DEFAULTSIZE or
      LR_LOADFROMFILE);

  GetObject(Bitmap, SizeOf(bmInfo), @bmInfo);

  W := bmInfo.dsBm.bmWidth;
  H := bmInfo.dsBm.bmHeight;

  bmiInfo.bmiHeader.biWidth:=W;            // ширина
  bmiInfo.bmiHeader.biHeight:=H;           // высота    
  bmiInfo.bmiHeader.biPlanes:=1;           // всегда 1    
  bmiInfo.bmiHeader.biBitCount:=24;        // три байта на пиксель    
  bmiInfo.bmiHeader.biCompression:=BI_RGB; // без компрессии    
  bmiInfo.bmiHeader.biSizeImage:=0;        // размер не знаем, ставим в ноль    
  bmiInfo.bmiHeader.biXPelsPerMeter:=2834; // пикселей на метр, гор.    
  bmiInfo.bmiHeader.biYPelsPerMeter:=2834; // пикселей на метр, верт.    
  bmiInfo.bmiHeader.biClrUsed:=0;          // палитры нет, все в ноль    
  bmiInfo.bmiHeader.biClrImportant:=0;     // то же    
  bmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); // размер структруы    
  bmDIB := CreateDIBSection(DC, bmiInfo, DIB_RGB_COLORS,
  Pointer(lpBits), 0, 0);
  //создаем независимый растр WxHx24, без палитры, в указателе lpBits получаем    
  //адрес первого байта этого растра. bmDIB - дискрептор растра    
  //заполняем первые шесть членов BITMAPINFO для передачи в GetDIBits    
  bmiInfo.bmiHeader.biWidth:=W;            // ширина    
  bmiInfo.bmiHeader.biHeight:=H;           // высота    
  bmiInfo.bmiHeader.biPlanes:=1;           // всегда 1    
  bmiInfo.bmiHeader.biBitCount:=24;        // три байта на пиксель    
  bmiInfo.bmiHeader.biCompression:=BI_RGB; // без компресси    
  bmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); // размер структуры    
  GetDIBits(DC, Bitmap, 0, H - 1, lpBits, bmiInfo, DIB_RGB_COLORS);

  p := Pointer(lpBits); 
   
  For i := 1 to 200 do  //простейший вывод на форму 
  for j := 1 to 250 do  //(только для проверки содержимого DIB)
   form1.Canvas.Pixels[i, 250 - j] := RGB(p^[j,i].r, p^[j,i].g, p^[j,i].b);
end;

Это сообщение отредактировал(а) alexeis1 - 29.9.2006, 01:06

--------------------

Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать

Alexeis

Дата 29.9.2006, 01:09 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459

Опять же процедурка для смешивания двух изображений с прозрачностью
(Взято из поста Snowy)

Код


procedure TForm1.Button1Click(Sender: TObject);    
var    
  bmp1, bmp2: TBitMap;    
  Blend: TBlendFunction;    
begin    
  bmp1 := TBitMap.Create;    
  bmp2 := TBitMap.Create;    
  bmp1.LoadFromFile('C:\1.bmp'); // загружаем 1 битмап    
  bmp2.LoadFromFile('C:\2.bmp'); // и второй битмап    
  bmp1.PixelFormat := pf32bit; // переводим оба в 32 бит    
  bmp2.PixelFormat := pf32bit;    
  Blend.BlendOp := AC_SRC_OVER;    
  Blend.BlendFlags := 0;    
  Blend.SourceConstantAlpha := 128; // прозрачность 50% (0 - 255)    
  Blend.AlphaFormat := AC_SRC_ALPHA;    
  // накладываем битмап 2 на битмап 1    
  if Windows.AlphaBlend(bmp1.Canvas.Handle, 0, 0, bmp1.Width, bmp1.Height,    
                        bmp2.Canvas.Handle, 0, 0, bmp2.Width, bmp2.Height, Blend) then    
    Canvas.Draw(0, 0, bmp1) // рисуем результат на форме    
  else ShowMessage(IntToStr(GetLastError)); // или код ошибки, если наложить не удалось    
  bmp1.Free; bmp2.Free; // уничтожаем битмапы    
end;

Добавлено @ 01:20

Вот еще любопытная ссылочка на интерпретатор паскаля (точнее его упрощеной версии)
http://alexboiko.narod.ru/prod.html

дальше решение популярного вопроса
" Проблемы русского языка в проектах Delphi 6-9, Или вопрос о ???????????"

http://forum.vingrad.ru/index.php?showtopi...092;?\?

Дальше простой вычислитель арифметических выражений на ОЛЕ (даже не помню кто его постил)

Код


var
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  sc: Variant;
begin
  SC:=CreateOLEObject('ScriptControl');
  try
    SC.Language:='VBScript';
    SC.Timeout:=-1;
    SC.AllowUI:=True;
    Label1.Caption:=SC.Eval(Edit1.Text);
  finally
    SC:=Unassigned;
  end;
end;

--------------------

Akella

Дата 29.9.2006, 08:52 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329

Цитата(Vit @ 28.9.2006, 18:04

)

Убедительная просьба ко всем кто публикует здесь материалы:

ПРОВЕРЯТЬ НЕТ ЛИ ИХ УЖЕ В ДРКБ. ПРОВЕРКА НА ДУБЛИКАТЫ - САМЫЙ ТРУДОЁМКИЙ ПРОЦЕСС, Я БУДУ НАДЕЯТСЯ НА ВАС И ТЕМЫ ОПУБЛИКОВАННЫЕ ЗДЕСЬ БУДУ ВКЛЮЧАТЬ В ДРКБ БЕЗ КАКИХ ЛИБО ПРОВЕРОК

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

Yanis

Дата 29.9.2006, 09:31 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 2937
Регистрация: 9.2.2004
Где: Москва

Репутация: 72
Всего: 111

Ещё раз, попрошу за Vit-а.

Voyager, читал этот пост?

--------------------

*щёлк*

Rouse_

Дата 29.9.2006, 12:24 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005

Репутация: 5
Всего: 29

Цитата(Snowy @ 29.9.2006, 00:23

)

Не убивайте
Этот вариант оптеделяет более детально, в отличие от 4-х способов DRKB.

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

Код


type
  _OSVERSIONINFOEX = record
    dwOSVersionInfoSize : DWORD;
    dwMajorVersion      : DWORD;
    dwMinorVersion      : DWORD;
    dwBuildNumber       : DWORD;
    dwPlatformId        : DWORD;
    szCSDVersion        : array[0..127] of AnsiChar;
    wServicePackMajor   : WORD;
    wServicePackMinor   : WORD;
    wSuiteMask          : WORD;
    wProductType        : BYTE;
    wReserved           : BYTE;
  end;
  TOSVERSIONINFOEX = _OSVERSIONINFOEX;

  function GetVersionEx(var lpVersionInformation: TOSVERSIONINFOEX): BOOL; stdcall;
    external kernel32 name 'GetVersionExA';

function GetOSType: String;
const
  VER_NT_WORKSTATION        =          $00000001;
  VER_NT_DOMAIN_CONTROLLER  =          $00000002;
  VER_NT_SERVER             =          $00000003;
  VER_SERVER_NT             =          $80000000;
  VER_WORKSTATION_NT        =          $40000000;
  VER_SUITE_SMALLBUSINESS   =          $00000001;
  VER_SUITE_ENTERPRISE      =          $00000002;
  VER_SUITE_BACKOFFICE      =          $00000004;
  VER_SUITE_COMMUNICATIONS  =          $00000008;
  VER_SUITE_TERMINAL        =          $00000010;
  VER_SUITE_SMALLBUSINESS_RESTRICTED = $00000020;
  VER_SUITE_EMBEDDEDNT      =          $00000040;
  VER_SUITE_DATACENTER      =          $00000080;
  VER_SUITE_SINGLEUSERTS    =          $00000100;
  VER_SUITE_PERSONAL        =          $00000200;
  VER_SUITE_BLADE           =          $00000400;
  VER_SUITE_EMBEDDED_RESTRICTED  =     $00000800;
  VER_SUITE_SECURITY_APPLIANCE   =     $00001000;
  SM_TABLETPC     = 86;
  SM_MEDIACENTER  = 87;
  SM_STARTER      = 88;
  SM_SERVERR2     = 89;
var
  osvi: TOSVERSIONINFOEX;
  bIsNt: Boolean;
begin
  Result := 'Не определена';
  ZeroMemory(@osvi, SizeOf(TOSVERSIONINFOEX));
  osvi.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFOEX);
  bIsNt := True;
  if not GetVersionEx(osvi) then
  begin
    bIsNt := False;
    osvi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
    if not GetVersionEx(osvi) then Exit;
  end;
  case osvi.dwPlatformId of
    VER_PLATFORM_WIN32s:
      Result := 'Microsoft Win32s';
    VER_PLATFORM_WIN32_WINDOWS:
    begin
      if (osvi.dwMajorVersion = 4) and (osvi.dwMinorVersion = 0) then
      begin
        Result := 'Windows 95 ';
        if (osvi.szCSDVersion[1] = 'C') or (osvi.szCSDVersion[1] = 'B') then
          Result := Result + 'OSR2';
      end;
      if (osvi.dwMajorVersion = 4) and (osvi.dwMinorVersion = 10) then begin
        Result := 'Windows 98 ';
        if osvi.szCSDVersion[1] = 'A' then Result := Result + 'SE';
      end;
      if (osvi.dwMajorVersion = 4) and (osvi.dwMinorVersion = 90) then
        Result := 'Windows Me';
    end;
    VER_PLATFORM_WIN32_NT:
    begin
      if (osvi.dwMajorVersion = 6) and (osvi.dwMinorVersion = 0) then
        if osvi.wProductType <> VER_NT_WORKSTATION then
          Result := 'Microsoft Windows Longhorn Server '
        else
          Result := 'Microsoft Windows Vista ';
      if (osvi.dwMajorVersion = 5) and (osvi.dwMinorVersion = 2) then
        Result := 'Microsoft Windows Server 2003, ';
      if (osvi.dwMajorVersion = 5) and (osvi.dwMinorVersion = 1) then
        Result := 'Microsoft Windows XP ';
      if (osvi.dwMajorVersion = 5) and (osvi.dwMinorVersion = 0) then
        Result := 'Microsoft Windows 2000 ';
      if (osvi.dwMajorVersion <= 4) then
        Result := 'Microsoft Windows NT ';

      if bIsNt then
      begin
        if osvi.wProductType = VER_NT_WORKSTATION then
        begin
          if osvi.dwMajorVersion = 4 then
            Result := Result + 'Workstation 4.0 '
          else
            if (osvi.wSuiteMask and VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL then
              Result := Result + 'Home Edition '
            else
              if GetSystemMetrics(SM_MEDIACENTER) <> 0 then
                Result := Result + 'Media Center Edition '
              else
                if GetSystemMetrics(SM_STARTER) <> 0 then
                    Result := Result + 'Starter '
                else
                  Result := Result + 'Professional ';
        end
        else
          if (osvi.wProductType = VER_NT_SERVER) or
            (osvi.wProductType = VER_NT_DOMAIN_CONTROLLER) then
          begin
            if (osvi.dwMajorVersion = 5) and (osvi.dwMinorVersion = 2) then
            begin
              if (osvi.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then
                Result := Result + 'Datacenter Edition '
              else
                if (osvi.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
                  Result := Result + 'Enterprise Edition '
                else
                  if (osvi.wSuiteMask and VER_SUITE_BLADE) = VER_SUITE_BLADE then
                    Result := Result + 'Web Edition '
                  else
                    if GetSystemMetrics(SM_SERVERR2) <> 0 then
                      Result := Result + '(.NET) Release 2 '
                    else
                      Result := Result + 'Standard Edition ';
            end
            else
              if (osvi.dwMajorVersion = 5) and (osvi.dwMinorVersion = 0) then
              begin
                if (osvi.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then
                  Result := Result + 'Datacenter Edition '
                else
                  if (osvi.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
                    Result := Result + 'Advanced Server '
                  else
                    Result := Result + 'Server ';
              end
              else
                if (osvi.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
                  Result := Result + 'Server 4.0, Enterprise Edition '
                else
                  Result := Result + 'Server 4.0 ';
          end;
      end;
      Result := Result + String(osvi.szCSDVersion) + ' ';  
    end;
  end;
end;

Это сообщение отредактировал(а) Rouse_ - 29.9.2006, 12:27

--------------------

Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru

Snowy

Дата 29.9.2006, 12:32 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 192
Всего: 484

Rouse_, неплохо. Только слова 'Microsoft ' и 'Windows ' можно было бы в константы вынести - уж слишком их тут много...

Rouse_

Дата 29.9.2006, 12:36 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005

Репутация: 5
Всего: 29

Логично, потом можно попоравить.

Вот еще пример получение информации по системным накопителям:

Код


function GetDrivesData(const NotNT: Boolean): String;

  function GetFreeSpace(Disk: String): String;
  var
    FA, TS: Int64;
    TF: TLargeInteger;
  begin
    if GetDiskFreeSpaceEx(PChar(Disk), FA, TS, @TF) then
      Result := IntToStr(Floor((TF / 1024) / 1024)) + ' Мб'
    else
      Result := 'не определено';
  end;

  function GetDriveFSName(Volume: String) : String;
  var
    VolumeName, FileSystemName: array [0..MAX_PATH - 1] of Char;
    VolumeSerialNo, MaxComponentLength, FileSystemFlags: LongWord;
  begin
    Result := '';
    if GetVolumeInformation(PChar(Volume), VolumeName, MAX_PATH, @VolumeSerialNo,
      MaxComponentLength, FileSystemFlags, FileSystemName, MAX_PATH) then
      Result :=  String(FileSystemName)
    else
      Result := '';
  end;

const
  NameSize = 4;
  VolumeCount = 26;
  TotalSize = NameSize * VolumeCount;
  Report = '  - Диск: %s %s'#13#10;
  ReportFull = '  - Диск: %s %s, файловая система: %s, свободно: %s'#13#10;
var
  Buff, Volume, svQuery: String;
  lpQuery: array [0..MAXCHAR - 1] of Char;
  I, Count: Integer;
begin
  SetLength(Buff, TotalSize);
  Count := GetLogicalDriveStrings(TotalSize, @Buff[1]) div NameSize;
  if Count = 0 then
    Result := 'Диски не определены'
  else
    Result := '';
    for I := 0 to Count - 1 do
    begin
      Volume := PChar(@Buff[(I * NameSize) + 1]);
      case GetDriveType(PChar(Volume)) of
        DRIVE_UNKNOWN: Result := Result + (Format(Report, [Volume,
          'Тип диска не определен.']));
        DRIVE_NO_ROOT_DIR:
          Result := Result + (Format(Report, [Volume,
            'Корневой путь диска не верен. Тип диска не определен.']));
        DRIVE_REMOVABLE:
        begin
          Volume[3] := #0;
          QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);
          Volume[3] := '\';
          if String(lpQuery) = '\Device\Floppy0' then
            Result := Result + (Format(Report, [Volume, 'Привод гибких дисков.']))
          else
            if String(lpQuery) = '\Device\Floppy1' then
              Result := Result + (Format(Report, [Volume, 'Привод гибких дисков.']))
            else
              Result := Result + (Format(ReportFull,
                [Volume, 'Флэш накопитель',
                GetDriveFSName(Volume), GetFreeSpace(Volume)]));
        end;
        DRIVE_FIXED:
        begin
          if NotNT then
          begin
            Volume[3] := #0;
            QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);
            Volume[3] := '\';
            if Length(String(lpQuery)) = 2 then
              Result := Result + (Format(ReportFull, [Volume,
                'Логический', GetDriveFSName(Volume), GetFreeSpace(Volume)]))
            else
              Result := Result + (Format(Report, [Volume,
                'Диск является отображением папки находящейся по адресу: "' +
                  String(lpQuery) + '"']));
            Continue;
          end;
          Volume[3] := #0;
          QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);
          Volume[3] := '\';
          if Copy(String(lpQuery), 1, 22)  = '\Device\HarddiskVolume' then
            Result := Result + (Format(ReportFull, [Volume,
              'Логический', GetDriveFSName(Volume), GetFreeSpace(Volume)]))
          else
            Result := Result + (Format(Report, [Volume,
              'Диск является отображением папки находящейся по адресу: "' +
                Copy(String(lpQuery), 5, Length(String(lpQuery))) + '"']));
        end;
        DRIVE_REMOTE:
        begin
          Volume[3] := #0;
          QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);
          Volume[3] := '\';
          svQuery := Copy(String(lpQuery), 29, Length(String(lpQuery)));
          Delete(svQuery, 1, Pos('\', svQuery));
          Result := Result + (Format(ReportFull, [Volume,
            'Удаленный (сетевой) диск. Сетевой путь: "\\' + svQuery + '"',
            GetDriveFSName(Volume), GetFreeSpace(Volume)]));
        end;
        DRIVE_CDROM:
          Result := Result + (Format(Report, [Volume,'CD-ROM.']));
        DRIVE_RAMDISK:
          Result := Result + (Format(ReportFull, [Volume, 'RAM диск.',
            GetDriveFSName(Volume), GetFreeSpace(Volume)]));
      else
        Result := (Format(Report, [Volume, 'Тип диска не определен.']));
      end;
    end;
end;

--------------------

Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru

Albinos_x

Дата 30.9.2006, 13:28 (ссылка)

(нет голосов)

Загрузка ...

Evil Skynet

Профиль
Группа: Комодератор
Сообщений: 3288
Регистрация: 28.5.2004
Где: X-6120400 Y-1 4624650

Репутация: 26
Всего: 108

Цитата(Akella @ 28.9.2006, 08:13

)

я хотел бы доработать свои статьия по Excel`

аналогично со статьёй по Word и Excel... хочу сделать более общирно и упорядоченно, плюс хосу добавить работу через Ole но если не успею, то предлогаю взять отсюда, то что уже есть:
http://forum.vingrad.ru/index.php?showtopi...34&view=all

Добавлено @ 13:33
код по вставке в StringGrid ComboBox, накатанная тема, но всё равно:
http://forum.vingrad.ru/index.php?showtopic=106903&st=15

--------------------

"Кто владеет информацией, тот владеет миром"
Уинстон Черчилль

Albinos_x

Дата 30.9.2006, 13:43 (ссылка)

(нет голосов)

Загрузка ...

Evil Skynet

Профиль
Группа: Комодератор
Сообщений: 3288
Регистрация: 28.5.2004
Где: X-6120400 Y-1 4624650

Репутация: 26
Всего: 108

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

Выставить ширину выпадающего списка по ширине строки

Код

...  
  procedure ComboWithStr(Combo:TComboBox);     
  var i,p,w:integer;     
  begin     
  w:=0;     
  for i:=0 to Combo.Items.Count-1 do     
     begin     
     p:=ComboBox1.Canvas.TextWidth(ComboBox1.Items.Strings[i]);     
     if p>w then w:=p;     
     end;     
 w:=w+5;     
 Combo.Perform(CB_SETDROPPEDWIDTH, w, 0);     
 end;  
 ...

использование:
  если строки не меняются в ComboBox-е, то целесообразней сделать так:

Код

...     
  procedure TForm1.FormCreate(Sender: TObject);     
  begin     
  ComboWithStr(ComboBox1);     
  end;     
  ...

если же меняется, то:

Код

...      
 procedure TForm1.ComboBox1DropDown(Sender: TObject);  
  begin     
  ComboWithStr(ComboBox1);     
  end;     
  ...

Добавлено @ 13:49
Фильтрация в ComboBox по маске

Задача:
  Исходные данные:
  1. ComboBox
  2. Список
  необходимо:
  когда пользователь набирает в списке отображать, только то что совпадает по маске с набранным.

функция:

Код


 procedure FilterComboList(Combo: TComboBox; L:TStringList);  
  var i, k:word;  
  pos:word;  
  j: integer;  
 begin  
 pos:=Combo.SelStart;  
 k:=L.Count;  
 j:=-1;  
 if k<>0 then  
    begin  
    Combo.Items.Clear;  
    for i:=0 to (k-1) do  
        begin  
        if AnsiLowerCase(Copy(L.Strings[i], 1, Length(Combo.Text))) = AnsiLowerCase(Combo.Text) then  
           begin  
           Combo.Items.Add(L.Strings[i]);  
           if L.Strings[i] = Combo.Text then  
               j:=Combo.Items.Count-1;  
          end;  
       Application.ProcessMessages;  
       end;  
   Combo.ItemIndex:=j;  
   Combo.SelStart:=pos;  
   end;  
 end;

использование:

Код


 procedure TForm1.ComboBox1Change(Sender: TObject);  
  begin  
  FilterComboList(ComboBox1, List);  
  end;

где List - TStringList.(т.е. список)
можно при получении фокуса (procedure TForm1.ComboBox1Enter(Sender: TObject) автоматически вызывать выпадающий список.
Да ещё необходимо, чтобы

Код


 ComboBox1.AutoComplete:=false;

иначе ничего не получится.

(идея: выпадающий список может содержать очень много строк и навигацию по этому, даже если поставить сортировку, осуществлять не очень удобно. А это значительно облегчает процесс)

Это сообщение отредактировал(а) Albinos_x - 30.9.2006, 13:44

--------------------

"Кто владеет информацией, тот владеет миром"
Уинстон Черчилль

Albinos_x

Дата 30.9.2006, 13:59 (ссылка)

(нет голосов)

Загрузка ...

Evil Skynet

Профиль
Группа: Комодератор
Сообщений: 3288
Регистрация: 28.5.2004
Где: X-6120400 Y-1 4624650

Репутация: 26
Всего: 108

выравнивание в Edit:

Код


const
  edLeft = 1;
  edRicht = 2;
  edCenter = 3;

procedure JustifyEdit(var ThisEdit : TEdit; Justify:byte);
var
 Left, Width : Integer;
 GString : String;
 Rgn : TRect;
 TheCanvas : TControlCanvas;  
begin
  TheCanvas := TControlCanvas.Create;  
  try
    TheCanvas.Control := ThisEdit;
    GString := ThisEdit.Text;  
    Rgn     := ThisEdit.ClientRect;
    TheCanvas.FillRect(Rgn);
    Width   := TheCanvas.TextWidth(GString);
    case Justify of
        1 : Left := 1;
        2 : Left := Rgn.Right - Width - 1;
        3 : Left := (Rgn.Right div 2) - (Width div 2) - 1;
        end;
    TheCanvas.TextRect(Rgn, Left, 0, GString);
  finally
    TheCanvas.Free;
  end ;
end;

использование:

Код


procedure TForm1.Button1Click(Sender: TObject);
begin
JustifyEdit(Edit1,edRicht);
end;

--------------------

"Кто владеет информацией, тот владеет миром"
Уинстон Черчилль

Quadr0

Дата 30.9.2006, 16:35 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

...

Это сообщение отредактировал(а) Quadr0 - 15.7.2011, 13:03

Albinos_x

Дата 30.9.2006, 20:31 (ссылка)

(нет голосов)

Загрузка ...

Evil Skynet

Профиль
Группа: Комодератор
Сообщений: 3288
Регистрация: 28.5.2004
Где: X-6120400 Y-1 4624650

Репутация: 26
Всего: 108

кстати в текущей версии Delphi Russian Knowledge Base в разделе
Работа с файлами средствами Win32API есть опечатка и не полностью описана одна или две команды... вот исправленный вариант с небольшим дополнением:

Код


function File0pen(const FileName: string; Mode: Word) : Integer;  
  Открывает существующий FileName файл в режиме Mode Значение, возвращаемое в случае успеха, — дескриптор открытого файла. В противном случае — код ошибки DOS.  
  
 function FileCreate(const PileName: string): Integer;  
  Создает файл с именем FileName. Возвращает то же, что и FileOpen.  
  
 function FileRead(Handle: Integer; var Buffer; Count: Longint): Longint;  
 Считывает из файла с дескриптором Handle Count байт в буфер Buffer. Возвращает число реально прочитанных байт или -1 при ошибке.  
 
 function FileWrite(Handle: Integer; const Buffer);  
 Записывает в файл с дескриптором Handle Count байт из буфера Buffer. Возвращает число реально записанных байт или -1 при ошибке.  

 function FileSeek(Handle: Integer; Offset: Longint; Origin: Integer): Longint;  
 Позиционирует файл с дескриптором Handle в новое положение. При Origin = 1,2,3 положение смещается на Offset байт от начала файла, текущей позиции и конца файла соответственно. Возвращает новое положение или -1 при ошибке.  

 procedure FileClose(Handle:Integer);  
 Закрывает файл с дескриптором Handle.  

 function FileAge(const FileName:String);  
 Возвращает значения даты и времени создания файла или -1, если файл не существует.  

 function FileExists(const FileName:String):boolean;  
 Возвращает True если файл FileName существует к найден.  

 function FindFirst(const Path: string; Attr: Integer; var SearchRec: TSearchRec): Integer;  
 Ищет первый файл, удовлетворяющий маске поиска, заданной в Path и с атрибутами Attr. В случае успеха заполняет запись SearchRec (см. примеч. 3) и возвращает 0, иначе возвращает код ошибки DOS. TSearchRec имеет структуру:  
  TSearchRec = record  
  Time :Integer;  
  Size :Integer;  
  Attr :Integer;  
  Name :TFileName;  
  ExcludeAttr :Integer;  
  FindHandle :THandle;  
  FindData :TWin32FindData;  
  end;  
параметр Attr может принимать значения:  
  faReadOnly - файл только для чтения  
  faHidden - невидимый файл  
  faSysFile - системный файл  
  faVolumeID - индефикатор диска  
  faDirectory - каталог  
  faArchive - архивный файл  
  faAnyFile - любой файл  

 function FindNext(var SearchRec: TSearchRec): Integer;  
 Продолжает процесс поиска файлов, удовлетворяющих маске поиска. Параметр SearchRec должен быть заполнен при помощи FindFirst. Возвращает 0, если очередной файл найден, или код ошибки DOS. Изменяет SearchRec.  

 procedure FindClose(var SearchRec: TSearchRec);  
 Завершает процесс поиска файлов, удовлетворяющих маске поиска.  

 function FileQetDate(Handle: Integer) : Longint;  
 Возвращает время создания файла с дескриптором Handle (в формате DOS) или -1, если дескриптор недействителен.  

 procedure FileSetDate(Handle: Integer;);  
 Устанавливает время создания файла с дескриптором Handle (в формате DOS).  

 function FileGetAttr(const FileName: string): Integer;  
 Возвращает атрибуты файла с именем FileName или код ошибки DOS, если файл не найден.  

 function FileSetAttrt(const FileName: string; Attr:Integer):Integer;  
 Устанавливает атрибуты файла с именем FileName.  

 function DeleteFile(const FileName:String);  
 Уничтожает файл с именем FileName и в случае успеха возвращает True.  

 function RenameFile(const OldName, NewName: string): Boolean;  
 Переименовывает файл с именем OldName в NewName и возвращает True в случае успеха.  

 function ChangeFileExt(const FileName, Extension: string): string;  
 Изменяет расширение в имени файла FileName на Extension и возвращает новое значение FileName. Имя файла не изменяется.  

 function ExtractFilePath(const FileName: string): string;  
 Извлекает из строки с полным именем файла FileName часть, содержащую путь к нему.  

 function ExtractFileName(const FileName: string): string;  
 Извлекает из строки с полным именем файла FileName часть, содержащую его имя и расширение.  

 function ExtractFileExt(const FileName: string): string;  
 Извлекает из строки с полным именем файла FileName часть, содержащую его расширение.  

 function ExpandFileName(const FileName: string): string;  
 Возвращает полное имя файла FileName, добавляя при необходимости путь к нему и переводя все символы в верхний регистр.  

 function FileSearch(const Name, DirList: string): strings;  
 Производит поиск файла с именем Name в группе каталогов, заданных параметром DirList. Имена каталогов должны отделяться друг от друга точкой с запятой. Возвращает в случае успеха полное имя файла или пустую строку, если файл не найден.  

 function DiskFree(Drive: Byte): Longint;  
 Возвращает количество в байтах свободного места на заданном диске. Значение параметра Drive: 0 — для текущего диска, 1 — для А, 2 — для В и т. д. Если параметр неверен, функция возвращает -1.  

 function DiskSize(Drive: Byte): Longint;  
 Возвращает размер диска Drive в байтах. Параметр Drive означает то же, что и в DiskFree.  

 function FileDateToDateTime(FileDate: Longint): TDateTime;  
 Преобразует дату и время в формате DOS в принятый в Delphi формат TDateTime.  

 function DateTimeToFileDate(DateTime: TDateTime): Longint;  
 Преобразует дату и время из формата TDateTime в формат DOS.

--------------------

"Кто владеет информацией, тот владеет миром"
Уинстон Черчилль

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »