Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум программистов > Delphi: Общие вопросы > Начался отбор тем для DRKB 3.0


Автор: Rouse_ 27.9.2006, 22:15
Итак,  http://vingrad.ru/@Vit) открывает следующий этап расширения http://www.drkb.ru/ . 
Что есть DRKB: это самая большая и полная в рунете база знаний по Дельфи, составленная по материалам форумов Vingrad.ru и Sources.ru, а так же других источников. Содержит более 2000 хорошо отклассифицированных и тщательно оформленных статей в формате chm (Windows Help).
Эта база составленна силами профессиональных программистов (и им сочуствующим) для программистов . 
Если вы желаете расширить эту базу своим материалом и стать совтором DRKB, то отправляйте Ваши материалы в данную ветку.
Добавление статьи в данную ветку происходит на Вашей доброжелательной основе.
Ваши материалы не рецензируются, но могут редактироваться.
Все статьи будут тщательно анализироваться сообществом модераторов форума и привлеченных извне специалистов по тематике статьи.
Статьи, помещеные в DRKB, обязательно будут иметь указание на автора статьи.
Большая просьба: не пишите по поводу непомещения Вашей статьи в DRKB. 
Если она не помещена в DRKB - значит она не прошла проверку на качество подачи материала или уровень изложения.
(Объяснения причин отсутствия статьи не разглашаются) 


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

Автор: Girder 27.9.2006, 22:17

Автор: Snowy 27.9.2006, 22:26
Какие-то сроки есть?
Или по мере наполнения?
Я хотел бы доработать свою статью и написать ещё одну.
Какой срок у меня есть?

Автор: Rouse_ 27.9.2006, 22:34
Сужу по себе, с таким объемом ранее нового года не справиться, поэтому ориентируйся примерно сюда, я тоже зажат со своей статьей и не знаю успею ли. Точнее о сроках Виталий скажет...

Автор: Snowy 27.9.2006, 22:39
Я примерно так и думал.
Ориентируемся на конец года, выход где-то в январе.

Добавлено @ 22:40 
Ориентировочно, естественно...

Автор: Akella 28.9.2006, 08:13
я хотел бы доработать свои статьия по Excel`ю, куда их можно сбросить?

Автор: Rouse_ 28.9.2006, 09:04
Akella, ну так сюда и кидай smile

Автор: Yanis 28.9.2006, 10:15
Цитата(Rouse_ @  27.9.2006,  23:34 Найти цитируемый пост)
Сужу по себе, с таким объемом ранее нового года не справиться, поэтому ориентируйся примерно сюда, я тоже зажат со своей статьей и не знаю успею ли. Точнее о сроках Виталий скажет...

Это будет отличный подарок на новый год всем участникам форума. Да что там форума, всему рунету!

Rouse_
Хорошо, что ты взялся помогать Виту. Чем больше спецов примет участие при её создании тем она будет качественнее исполнена ;)

Добавлено @ 10:18 
Ещё вопросы.
А что будем делать с наработками из http://forum.vingrad.ru/index.php?showtopic=21411? Просто тупа перекидывать линки на посты оттуда сюда?
В теме про DRKB версии 2.3 много постов с указаниями на ошибки и неточности. Будут ли они учтены? Так же там имеются и наработки некоторых людей, которые стоит добавить в DRKB.

Автор: Akella 28.9.2006, 14:04
Я когда-то для DRKB давал исходники по импорту из Excel (прошу обратить внимание, что тогда я был под ником dsergey)
Прошу заменить импорт из Excel на эту процедуру, т.к. она работает на много быстрее. (Тогда она называлась ImportFromExcel, помоему)
Экспорт в Excel не менял  smile 

даю полностью рабочий код

Код

uses ...
ExcelXP, OleServer, ComObj, ...

{
Ex1 - TExcelApplication со страницы Servers
dm - TDataModule
tArrivalDet, tPreparats, tArrival - TpFibDataBase
считаю, что такие функции, как DelProb или FindPreparat не требуется сюда выкладывать, т.к. у всех своя специфика, тем
более, что они никакого отношения не имеют к импорт из Excel
}
procedure TfmImpFromExcel.ImportArrivalFromExcel(FileName: String);
Var
 WorkBk : _WorkBook; //  определяем WorkBook
 WorkSheet : _WorkSheet; //  определяем WorkSheet
 Range:OleVariant;
 iUnitID,iUnit, iAmount, iTerm,iPrepID, iSeries, iStop, iProd, iPrice, RowsToCopy, iLastRow, iWBIndex, x, iBook, iNameRow : integer;
 sInvoiceNum, sUnitCol, sAmountCol, sTermCol, sProdCol, sPriceCol, sNameCol, sSeriesCol, sFileName : String;
 bNaydeno7, bNaydeno6, bNaydeno5, bNaydeno4, bNaydeno2, bNaydeno1, bNaydeno, bNaydeno3 : boolean;
 vPrep:variant;
 НайденоВБазе, НеНайденоВБазе:integer;
 Препарат, Производитель, Серия, Единица: String;
 ЦенабНДС,НДС, ЦенаСНДС : real;
 ArrivalID : integer;
begin
  sFileName := '';
  screen.Cursor := crHourGlass;
  try
    sInvoiceNum := AnsiUpperCase(ExtractFileName(FileName));
    sInvoiceNum := Copy(sInvoiceNum, 1, pos('.XLS',sInvoiceNum)-1);
    fmNewArrival.edInvoice_num.Text := sInvoiceNum;
    dm.tPreparats.DisableControls;
    dm.tPreparats.AutoCommit := false;

    if not dm.tArrivalDet.active then
      dm.tArrivalDet.Open;

    dm.tArrivalDet.DisableControls;
    dm.tArrivalDet.AutoCommit := False;

    dm.tArrivalDet.BeforeInsert := nil;
    dm.tArrivalDet.AfterPost    := nil;

    НеНайденоВБазе := 0;
    НайденоВБазе := 0;
    try//попытка открытия файла
      Ex1.Connect;
      Ex1.Workbooks.Open(FileName,EmptyParam,EmptyParam,EmptyParam,EmptyParam,
          EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam, EmptyParam,EmptyParam,
          EmptyParam,EmptyParam,EmptyParam, LOCALE_USER_DEFAULT);
      Ex1.Application.EnableEvents := false;
     except;//в случае ошибки все отменяем и обнуляем
       screen.Cursor:=crDefault;
       RowsToCopy := 0;
       exit;
     end;//try-except Ex1.Connect

     sFileName := ExtractFileName(FileName);
     For iWBIndex := 1 to ex1.Workbooks.Count do
       if ex1.Workbooks.Item[iWBIndex].Name = sFileName then break;
     WorkBk := ex1.WorkBooks.Item[iWBIndex];   // Выбираем WorkBook

   // Определяем WorkSheet
   if WorkBk.Worksheets.Count>1 then
   begin//если кол-во листов больше 1
     For x:=0 to memoSheets.Lines.Count-1 do
     begin
      For iBook:=1 to WorkBk.Worksheets.Count do
      begin
        WorkSheet:=WorkBk.WorkSheets.Get_Item(iBook) as _WorkSheet;
        if WorkSheet.Name = memoSheets.Lines[x] then
        begin
          bNaydeno3:=True;//нашли лист
          WorkSheet.Activate(LOCALE_USER_DEFAULT);//активираем лист
        end;//if WorkSheet.Name = memoSheets.Lines[x] then begin
        if bNaydeno3 then break;
      end;//For iBook:=1 to WorkBk.Worksheets.Count do begin
      if bNaydeno3 then break;
     end;//For x:=0 to memoSheets.Lines.Count-1 do begin
     //если не находим лист из списка ключевых слов, выдаем сообщение
     if not bNaydeno3 then
     begin
         beep;
         ShowMessage('<Не найден лист с данными>'+#13+#13+
         '1.Откройте прайс, посмотрите название листа с препаратами, добавьте в'+#13+
         'ключевые слова название листа с препаратами и повторите импорт'+#13+
         '___________________________________________________________________________________'+#13+
         '2.Откройте прайс, выберите лист с препаратами, затем выберите меню "Файл->Сохранить и закройте Excel"');

         exit;
     end;//if bNaydeno3=false then begin
   end else//if
     WorkSheet:=WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;;

   StatusBar1.Panels[0].Text:='Поиск последней строки...';
   application.ProcessMessages;
   if Find('99999',iNameRow, sNameCol, WorkSheet) then
     begin
       iLastRow:=iNameRow-1;//в столбце с наименованием ищем "99999"-конец импорта
     end
   else
     begin     //и запоминаем в iRows
      try//если не находим 99999 то ищем последнюю заполненную ячейку
        WorkSheet.Cells.SpecialCells(xlCellTypeLastCell,EmptyParam).Activate;
        // Получаем значение последней строки
        iLastRow:=(ex1.ActiveCell.Row)-1;
       except
         try
           WorkSheet.Cells.SpecialCells(xlCellTypeLastCell,EmptyParam).Select;
           // Получаем значение последней строки
           iLastRow:=(ex1.ActiveCell.Row);
         except
           iLastRow:=0;
         end;//try-except
       end;//try-except
     end;//else

   if iLastRow=0 then
   begin
     memoErrors.Lines.Add(TimeToStr(Time)+' Не найден признак окончания данных, импортируем 6000 строк');
     iLastRow:=6000;
   end;//if iRows=0 then begin

   //показываем кол-во строк для копирования
   memoErrors.Lines.Add(TimeToStr(Time)+' Записей для импорта '+IntToStr(RowsToCopy));

//ищем наименование препаратов
   For x:=0 to memoName.Lines.Count-1 do
   begin
     bNaydeno:=False;
     if Find(memoName.Lines[x],iNameRow,sNameCol,WorkSheet) then begin
      bNaydeno:=True;
      //количество строк для копирования
      RowsToCopy := iLastRow - iNameRow;
      break;
     end;//if Find(memoNames.Lines[r],iNameRow,sNameCol) then begin
   end;//For r:=0 to memoNames.Lines.Count-1 do begin

   if not bNaydeno then
   begin
     beep;
     ShowMessage('<Не найден столбец с наименованиями>'+#13+#13+
         '1.Откройте прайс, посмотрите название столбца с наименованиями,'+#13+
         'добавьте в ключевые слова название этого столбца и повторите импорт'+#13+
         '-----------------------------------------------------------------------------'+#13+
         '2.Откройте прайс, выберите лист с препаратами, затем выберите меню "Файл->Сохранить"');
     memoErrors.Lines.Add(TimeToStr(Time)+' Не найден столбец с производителем препаратов.');
     memoErrors.Lines.Add(TimeToStr(Time)+' Импорт завершен неудачно');
     memoErrors.Lines.Add('___________________________________________');
     exit;
   end;//if bNaydeno2=False then begin

//ищем серию препаратов
   For x:=0 to memoSeries.Lines.Count-1 do
   begin
     bNaydeno4:=False;
     if Find(memoSeries.Lines[x],iSeries,sSeriesCol,WorkSheet) then
     begin
      bNaydeno4:=True;
      break;
     end;
   end;

   if not bNaydeno4 then
   begin
     beep;
     ShowMessage('<Не найден столбец с сериями препаратов>'+#13+#13+
         '1.Откройте прайс, посмотрите название столбца с сериями препаратов, добавьте в'+#13+
         'ключевые слова название этого столбца и повторите импорт.'+#13+
         '___________________________________________________________________________________'+#13+
         '2.Откройте прайс, выберите лист с препаратами, затем выберите меню "Файл->Сохранить"');
     memoErrors.Lines.Add(TimeToStr(Time)+' Не найден столбец с сериями препаратов.');
     memoErrors.Lines.Add(TimeToStr(Time)+' Импорт завершен неудачно');
     memoErrors.Lines.Add('___________________________________________');
     exit;
   end;

//ищем Ед. изм препаратов
   For x:=0 to memoUnits.Lines.Count-1 do
   begin
     bNaydeno7:=False;
     if Find(memoUnits.Lines[x],iUnit,sUnitCol,WorkSheet) then
     begin
      bNaydeno7:=True;
      break;
     end;
   end;

   if not bNaydeno7 then
   begin
     beep;
     ShowMessage('<Не найден столбец с единицами измерений>'+#13+#13+
         '1.Откройте прайс, посмотрите название столбца с ед.изм., добавьте в'+#13+
         'ключевые слова название этого столбца и повторите импорт.'+#13+
         '___________________________________________________________________________________'+#13+
         '2.Откройте прайс, выберите лист с препаратами, затем выберите меню "Файл->Сохранить"');
     memoErrors.Lines.Add(TimeToStr(Time)+' Не найден столбец с сериями препаратов.');
     memoErrors.Lines.Add(TimeToStr(Time)+' Импорт завершен неудачно');
     memoErrors.Lines.Add('___________________________________________');
     exit;
   end;

//ищем цену препаратов
   For x:=0 to memoPrice.lines.Count-1 do
   begin
     bNaydeno1:=False;
     if Find(memoPrice.lines[x],iPrice,sPriceCol,WorkSheet) then begin
      bNaydeno1:=True;
      break;
     end;//if Find(memoPrices.lines[r],iPriceRow,sPriceCol) then begin
   end;//For r:=0 to memoPrices.lines.Count-1 do begin
   if not bNaydeno1 then
   begin
     beep;
     ShowMessage('<Не найден столбец с ценами препаратов>'+#13+#13+
         '1.Откройте прайс, посмотрите название столбца с ценами препаратов, добавьте в'+#13+
         'ключевые слова название этого столбца и повторите импорт.'+#13+
         '___________________________________________________________________________________'+#13+
         '2.Откройте прайс, выберите лист с препаратами, затем выберите меню "Файл->Сохранить"');
     memoErrors.Lines.Add(TimeToStr(Time)+' Не найден столбец с ценами препаратов.');
     memoErrors.Lines.Add(TimeToStr(Time)+' Импорт завершен неудачно');
     memoErrors.Lines.Add('___________________________________________');
     exit;
   end;//if bNaydeno1=false then begin

//ищем количество
   For x:=0 to memoAmount.lines.Count-1 do
   begin
     bNaydeno6:=False;
     if Find(memoAmount.lines[x],iAmount,sAmountCol,WorkSheet) then begin
      bNaydeno6:=True;
      break;
     end;//if Find(memoPrices.lines[r],iPriceRow,sPriceCol) then begin
   end;//For r:=0 to memoPrices.lines.Count-1 do begin
   if not bNaydeno6 then
   begin
     beep;
     ShowMessage('<Не найден столбец "количество">'+#13+#13+
         '1.Откройте прайс, посмотрите название столбца с количеством, добавьте в'+#13+
         'ключевые слова название этого столбца и повторите импорт.'+#13+
         '___________________________________________________________________________________'+#13+
         '2.Откройте прайс, выберите лист с препаратами, затем выберите меню "Файл->Сохранить"');
     memoErrors.Lines.Add(TimeToStr(Time)+' Не найден столбец "количество".');
     memoErrors.Lines.Add(TimeToStr(Time)+' Импорт завершен неудачно');
     memoErrors.Lines.Add('___________________________________________');
     exit;
   end;//if bNaydeno1=false then begin


//ищем производителя препаратов
   For x:=0 to memoProducer.Lines.Count-1 do
   begin
     bNaydeno2:=False;
     if Find(memoProducer.Lines[x],iProd,sProdCol,WorkSheet) then begin
      bNaydeno2:=True;
      break;
     end;//if Find(memoProd.Lines[r],iProdRow,sProdCol) then begin
   end;//For r:=0 to memoProd.Lines.Count-1 do begin
   if not bNaydeno2 then
   begin
     beep;
     ShowMessage('<Не найден столбец с наименованиями производителей>'+#13+#13+
         '1.Откройте прайс, посмотрите название столбца с наименованиями производителей,'+#13+
         'добавьте в ключевые слова название этого столбца и повторите импорт'+#13+
         '-----------------------------------------------------------------------------'+#13+
         '2.Откройте прайс, выберите лист с препаратами, затем выберите меню "Файл->Сохранить"');
     memoErrors.Lines.Add(TimeToStr(Time)+' Не найден столбец с производителем препаратов.');
     memoErrors.Lines.Add(TimeToStr(Time)+' Импорт завершен неудачно');
     memoErrors.Lines.Add('___________________________________________');
     exit;
   end;//if bNaydeno2=False then begin


//ищем срок годности препаратов
   For x:=0 to memoTerm.Lines.Count-1 do
   begin
     bNaydeno5:=False;
     if Find(memoTerm.Lines[x],iTerm,sTermCol,WorkSheet) then begin
      bNaydeno5:=True;
      break;
     end;//if Find(memoProd.Lines[r],iProdRow,sProdCol) then begin
   end;//For r:=0 to memoProd.Lines.Count-1 do begin
   if not bNaydeno5 then
   begin
     beep;
     ShowMessage('<Не найден столбец со сроком годности препаратов>'+#13+#13+
         '1.Откройте прайс, посмотрите название столбца со сроком годности,'+#13+
         'добавьте в ключевые слова название этого столбца и повторите импорт'+#13+
         '-----------------------------------------------------------------------------'+#13+
         '2.Откройте прайс, выберите лист с препаратами, затем выберите меню "Файл->Сохранить"');
     memoErrors.Lines.Add(TimeToStr(Time)+' Не найден столбец со сроком годности препаратов.');
     memoErrors.Lines.Add(TimeToStr(Time)+' Импорт завершен неудачно');
     memoErrors.Lines.Add('___________________________________________');
     exit;
   end;//if bNaydeno2=False then begin


   pb1.Max:=RowsToCopy;
   StatusBar1.Panels[0].Text:='Импорт начат...';
   application.ProcessMessages;
   iStop := 0;
//начинаем импорт со строки iNameRow

//начинаем импорт со строки iNameRow
    Inc(iNameRow);
    For x:=0 to RowsToCopy do
    with dm do
    begin
      Препарат      := Trim(VarToStr(WorkSheet.Cells.Item[iNameRow,sNameCol].Value));
      if (POS('ОТПУЩЕНО',AnsiUpperCase(Препарат)) <> 0) or
         (POS('ВСЕГО',AnsiUpperCase(Препарат)) <> 0) or
         (POS('ОПЛАТА',AnsiUpperCase(Препарат)) <> 0) or
         (Препарат = '')
      then continue;

      Серия         := Trim(VarToStr(WorkSheet.Cells.Item[iNameRow,sSeriesCol].Value));
      Производитель := Trim(VarToStr(WorkSheet.Cells.Item[iNameRow,sProdCol].Value));
      Единица       := Trim(VarToStr(WorkSheet.Cells.Item[iNameRow,sUnitCol].Value));
      if Единица = '' then Единица := 'шт';
      

      if cbWithVAT.Checked then begin
        ЦенабНДС := StrToFloatDef(DelProb(VarToStr(WorkSheet.Cells.Item[iNameRow,sPriceCol].Value)),0);
        НДС      := (ЦенабНДС * 1.2)-ЦенабНДС;
        ЦенаСНДС := ЦенабНДС + НДС;
      end else begin//без НДС
        ЦенабНДС := StrToFloatDef(DelProb(VarToStr(WorkSheet.Cells.Item[iNameRow,sPriceCol].Value)),0);
        НДС      := 0.00;
        ЦенаСНДС := ЦенабНДС;
      end;

      if (Препарат = '') or (Препарат = ' ')
      then
       Inc(iStop)//если пустая строка, то увеличиваем на 1
      else
       iStop := 0;//если следующая не пустая то обнуляем и продолжаем импорт
      //если начались пустые строки то прекращаем импорт
      if iStop > 4 then break;

      //наименование препарата сначала нужно найти в справочнике препаратов
      iPrepID := -1;

      ArrivalID := tArrivalID.Value;

      if (tArrival.state = dsEdit) or (tArrival.state = dsInsert) then begin
        tArrival.post;
        tArrival.locate('ID', ArrivalID, []);
        tArrival.edit;
      end;

      if FindPreparat(Препарат, Производитель, iPrepID)
      then
        begin//если нашли, то у нас есть его ID, т.е. iPrepID
          //добавляем в приход
          Inc(НайденоВБазе);

          tArrivalDet.Append;
          tArrivalDetARRIVAL_ID.Value     := ArrivalID;
          tArrivalDetPREPARAT_ID.Value    := iPrepID;
          tArrivalDetPRICE_WO_NDS.AsFloat := ЦенаБНДС;
          tArrivalDetPRICE_W_VAT.AsFloat  := ЦенаСНДС;
          tArrivalDetVAT.AsFloat          := НДС;
          tArrivalDetPRICE_RETAIL.AsFloat := RoundPrice(RoundTo(ЦенаСНДС * fmNewArrival.ceCoeff.Value,-2));
          tArrivalDetAMOUNT.Value         := StrToFloatDef(DelProb(VarToStr(WorkSheet.Cells.Item[iNameRow,sAmountCol].Value)),0);
          tArrivalDetSERIES.AsString      := Серия;
          tArrivalDetUNIT_ID.Value      := FindUnit(Единица);

          tArrivalDet.Post;
        end
      else
        begin//добавляем в справочник препаратов новый препарат
          Inc(НеНайденоВБазе);
          tPreparats.Append;
              iPrepID := tPreparatsID.Value;
              tPreparatsNAME.Value            := Препарат;
              tPreparatsPRODUCER.Value        := Производитель;
              tPreparatsSERIES.Value          := Серия;
              tPreparatsPRICE_RETAIL.AsFloat  := RoundPrice(RoundTo(ЦенаСНДС * fmNewArrival.ceCoeff.Value,-2));
              tPreparatsPRICE_WO_VAT.AsFloat  := ЦенаСНДС;
              tPreparatsTERM.Value            := Trim(VarToStr(WorkSheet.Cells.Item[iNameRow,sTermCol].Value));
              tPreparatsUNIT_ID.Value      := FindUnit(Единица);

              tPreparats.Post;

          //а теперь добавляем его в приход
          tArrivalDet.Append;
          tArrivalDetARRIVAL_ID.Value     := tArrivalID.Value;
          tArrivalDetPREPARAT_ID.Value    := iPrepID;
          tArrivalDetUNIT_ID.Value        := FindUnit(Единица);
          tArrivalDetPRICE_WO_NDS.AsFloat := ЦенаБНДС;
          tArrivalDetPRICE_W_VAT.AsFloat  := ЦенаСНДС;
          tArrivalDetVAT.AsFloat          := НДС;
          tArrivalDetPRICE_RETAIL.AsFloat := RoundPrice(RoundTo(ЦенаСНДС * fmNewArrival.ceCoeff.Value,-2));
          tArrivalDetAMOUNT.Value         := StrToFloatDef(DelProb(VarToStr(WorkSheet.Cells.Item[iNameRow,sAmountCol].Value)),0);
          tArrivalDetUNIT_ID.Value      := FindUnit(Единица);
          tArrivalDetSERIES.AsString      := Серия;
          tArrivalDet.Post;
        end;

        Inc(iNameRow);
        pb1.Position := x;
        application.ProcessMessages;
        if bAbort then  Break;

    end;//For e:=0 to RowsToCopy do begin


  finally
    memoErrors.Lines.Add('Завершение импорта...');
    dm.tPreparats.EnableControls;
    dm.tArrivalDet.EnableControls;

    dm.tArrivalDet.BeforeInsert := dm.tArrivalDetBeforeInsert;
    dm.tArrivalDet.AfterPost    := dm.tArrivalDetAfterPost;


    if dm.tArrivalDet.UpdateTransaction.InTransaction then dm.tArrivalDet.UpdateTransaction.Commit;
    if DM.tPreparats.UpdateTransaction.InTransaction then DM.tPreparats.UpdateTransaction.Commit;

    dm.tArrivalDet.AutoCommit := true;
    DM.tPreparats.AutoCommit := true;

    memoErrors.Lines.Add('Найдено в справочнике препаратов: '+IntToStr(НайденоВБазе));
    memoErrors.Lines.Add('Добавлено новых в справочник препаратов: '+IntToStr(НеНайденоВБазе));
    memoErrors.Lines.Add('Импорт завершен');
    StatusBar1.Panels[0].Text := 'Импорт завершен';
    Screen.Cursor := crDefault;
  end;
end;


Код

Function TfmImpExcel.Find(sText:String;Var iRow:Integer;Var sCol:String;WorkSheetF:_WorkSheet):Bool;

Var

UsedRange, Range: OLEVariant;

t,y:Integer;//вспомогат для импорта

FirstAddress: string;

begin //поиск начали

Result:=False;

UsedRange := WorkSheetF.Range['A1','Z5000'];//диапазон поиска, напрмер от 'F25' до 'G30'

Range := UsedRange.Find(What:=sText, LookIn := xlValues, LookAt := xlWhole,SearchDirection := xlNext);

if not VarIsClear(Range) then begin

  try

    FirstAddress := Range.Address;

    //вычисляем номер строки из полученного адреса(абсолютные координаты)

    //он начинается после второго значка доллара

    //формат найденной строки,что-то типа $A$2 (абсолютные координаты)

    t:=PosEx('$',FirstAddress,2);

    iRow:=StrToInt(Copy(FirstAddress,t+1,length(FirstAddress)-t));

    //вычисляем номер столбца из полученного адреса(абсолютные координаты)

    //буква начинается со второго символа

    y:=PosEx('$',FirstAddress,2);

    sCol:=Copy(FirstAddress,2,y-2);

    Result:=true;

    VarClear(Range);

    VarClear(UsedRange);

  except

    Result:=False;

  end;//try-except

end;//if

end;

Автор: Vit 28.9.2006, 14:33
Цитата(Rouse_ @  27.9.2006,  13:34 Найти цитируемый пост)
Сужу по себе, с таким объемом ранее нового года не справиться, поэтому ориентируйся примерно сюда, я тоже зажат со своей статьей и не знаю успею ли. Точнее о сроках Виталий скажет... 


Я хотел раньше... хотя может Rouse_ и более приземлён smile . Тем более что появилось время заниматься этим в рабочее время.
Ладно, работаем, а потом посмотрим...

Цитата(Yanis @  28.9.2006,  01:15 Найти цитируемый пост)
А что будем делать с наработками из Арсенал форумистов? Просто тупа перекидывать линки на посты оттуда сюда?


Не надо, я сам по тому разделу пройдусь

И ещё:

Я собираюсь сделать ещё и небольшой файл-архив с примерами кода, полезными утилитами и компонентами. Бросайте линки сюда, я залью к себе на FTP 

Автор: Yanis 28.9.2006, 16:37
Цитата(Vit @  28.9.2006,  15:33 Найти цитируемый пост)
Я собираюсь сделать ещё и небольшой файл-архив с примерами кода, полезными утилитами и компонентами. Бросайте линки сюда, я залью к себе на FTP 

Не знаю на сколько это хорошая идея. Работа над DRKB, как Vit сам и говорил, очень трудоёмкая. Хватит ли на всё это времени и сил?

http://forum.vingrad.ru/index.php?showtopic=110772&view=findpost&p=846928
Помоему неплохой примерчик.
Код демонстрирует как можно найти уже запущенный процесс и получить его PID. Ко всему там же имеется пример как подцепиться к работающему процессу и дождаться его завершения.

П. С. К сожалению "достать" код получения PID процесса из DRKB очень сложно. Кто не верит смотрите "Как завершить задачу в Windows NT (а заодно получить PID задачи)? 

http://forum.vingrad.ru/index.php?showtopic=113018&view=findpost&p=865888
Как проверить является ли файл файлом Excel-я

Автор: Yanis 28.9.2006, 16:59
http://forum.vingrad.ru/index.php?showtopic=108215
Как определить размер кластера?

Добавлено @ 17:11 
http://forum.vingrad.ru/index.php?showtopic=97353
Отлов исключительных ситуаций в консольных приложениях

Автор: Yanis 28.9.2006, 17:15
потеря активности проследить
http://forum.vingrad.ru/index.php?showtopic=94500
Предложеный мною в этом топике вариант имеет приимущество перед стандартным OnActivate/OnDeactivate smile 

Автор: Vit 28.9.2006, 18:04
Убедительная просьба ко всем кто публикует здесь материалы: 

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

Автор: Elfebet 28.9.2006, 19:02
Exe - SFX или нет.
http://forum.vingrad.ru/index.php?showtopic=107391
автор:Snowy

Перенести все компоненты при переустановке Delphi 
http://www.delphikingdom.ru/asp/viewitem.asp?catalogid=854

Автор: Voyager 28.9.2006, 19:26
Вот может что приглянется:

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

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

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

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

Автор: Vit 28.9.2006, 22:25
Цитата(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



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

Автор: Snowy 28.9.2006, 23:23
http://forum.vingrad.ru/index.php?showtopic=97620 (статья by Quadr0)

http://forum.vingrad.ru/index.php?showtopic=112648&view=findpost&p=860350
Решение простое, но может пригодиться smile

http://forum.vingrad.ru/index.php?showtopic=109636
Решение конечно не претендует на 100% полноценность, но лучше, чем ничего. Дорабатывать до полнофункционала очень лениво. Но, кому надо, дальше сам разберётся.

http://forum.vingrad.ru/index.php?showtopic=63257&view=findpost&p=511957
Ну уж очень регулярный вопрос. Решение не сложное - вопрос частый.

http://forum.vingrad.ru/index.php?showtopic=47363&view=findpost&p=368089
В DRKB есть, но там на плюсах. Эта на Delphi.

http://forum.vingrad.ru/index.php?showtopic=41287&view=findpost&p=317020
Не убивайте smile
Этот вариант оптеделяет более детально, в отличие от 4-х способов DRKB.

http://forum.vingrad.ru/index.php?showtopic=38317&view=findpost&p=289628
Не знаю, насколько нужный код. Но он маленький - много места не займёт - смотрите сами, нужен или нет.

Автор: Alexeis 29.9.2006, 00:51
Цитата(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?showtopic=94227&hl=%D1%84%D0%BE%D1%80%D0%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;

Автор: Alexeis 29.9.2006, 01:09
Опять же процедурка для смешивания двух изображений с прозрачностью
(Взято из поста 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?showtopic=82093&view=all&hl=%D0%B2%D0%BE%D0%BF%D1%80%D0%BE%D1%81,and,\?\?\?


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

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
Цитата(Vit @  28.9.2006,  18:04 Найти цитируемый пост)
Убедительная просьба ко всем кто публикует здесь материалы: 

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

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

Автор: Yanis 29.9.2006, 09:31
Ещё раз, попрошу за Vit-а.

Voyager, читал http://forum.vingrad.ru/index.php?showtopic=113874&view=findpost&p=870461 пост?

Автор: Rouse_ 29.9.2006, 12:24
Цитата(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;

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

Автор: Rouse_ 29.9.2006, 12:36
Логично, потом можно попоравить.

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

Код

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;

Автор: Albinos_x 30.9.2006, 13:28
Цитата(Akella @  28.9.2006,  08:13 Найти цитируемый пост)
я хотел бы доработать свои статьия по Excel`

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

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

Автор: Albinos_x 30.9.2006, 13:43
ещё в арсенале был выложен код печати 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:59
выравнивание в 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
...

Автор: Albinos_x 30.9.2006, 20:31
кстати в текущей версии 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.  

Автор: Voyager 2.10.2006, 07:02
Вот моя функция получения пути до программы из файла ярлыка:
Код

Uses ShlObj, ActiveX;

function IShellLinkGetPath(szFile:string):string;
var
  pSL  : IShellLink;
  pPF  : IPersistFile;
  hRes : HRESULT;
  wsz  : array [0..MAX_PATH] of WideChar;
  szGotPath : array [0..MAX_PATH] of Char;
  pfd: TWin32FindData;
begin
  If not fileexists(szFile) then exit;
  CoInitialize(nil);
  hRes := CoCreateInstance(CLSID_ShellLink,
          nil,
          CLSCTX_INPROC_SERVER,
          IShellLink,
          pSL);
  if SUCCEEDED(hRes) then
    begin
      hRes := pSL.QueryInterface(IPersistFile,pPF);
      if SUCCEEDED(hRes) then
        begin
          StringToWideChar(szFile, wsz, SizeOf(wsz));
          hRes := pPF.Load(wsz, STGM_READ);
          if SUCCEEDED(hRes) then
            begin
              hRes := pSL.GetPath(szGotPath,
                      MAX_PATH,
                      pfd,
                      SLGP_UNCPRIORITY);
              if SUCCEEDED(hRes) then
                result := szGotPath;
            end;
        end;
    end;
  CoUninitialize;
end;

Автор: Sunvas 5.10.2006, 16:19
Вот мое решение как нарисовать эффект "Муравьи" на форме.
http://forum.vingrad.ru/index.php?showtopic=89615&view=findpost&p=693628

Автор: FF90h 8.10.2006, 13:13
 Смена МАК адреса тестировал на WinXP Prof Sp1 Sp2 WinXp Home

Код

...
uses Registry;
...
var
  Registry: TRegistry;
...
  Registry := TRegistry.Create;
  Registry.RootKey := HKEY_LOCAL_MACHINE;
  Registry.OpenKey('SYSTEM\CurrentControlSet\Control\Class\{4D36E972-E325-11CE-BFC1-08002bE10318}\0008',false);
  Registry.WriteString('NetworkAddress','С0FFE21FС000');
  //С0-FF-E2-1F-С0-00 Новый МАК
  //www.microsoft.com/technet/prodtechnol/windows2000serv/reskit/regentry/85478.mspx
  Registry.CloseKey;
  Registry.Free;
...

Автор: Sunvas 9.10.2006, 20:57
Элементы комбинаторики - размещения, перестановки, сочетания

Вот три функции для вычисления всех возможных вариантов выбора элементов методом сочетания, перестановки и размещения. Где s -  строка элементов, k - количество элементов при выборе, povtor - возможность повторения элементов.
Строки, поступающие в эти функции не должны содержать одинаковых символов. Строки, которые содержат одинаковые символы, перед подачей в функцию надо нормализировать при помощи функции normalize;

Код

function sochetanie(s:string;k:word;povtor:boolean):tstrings;
var p:pboolean;
    c:string;
    strlist:tstringlist;
 procedure proced(zn,dl:word);
 var w:integer;
 begin
   for w:=1 to length(s) do
     begin
       if ((p^)and(pos(c[zn-1],s)<=w))or((not p^)and(pos(c[zn-1],s)<w)) then
         begin
            c[zn]:=s[w];
            if zn<dl then proced(zn+1,dl);
            if zn=dl then strlist.Add(c);
         end;
     end;
 end;
begin
strlist:=tstringlist.Create;
strlist.Clear;
if (k=length(s))and(not povtor) then
  begin
    strlist.Add(s);
    result:=strlist;
    exit;
  end;
new(p);
if k<=length(s) then p:=@povtor else p^:=true;
setlength(c,k);
proced(1,k);
result:=strlist;
end;

function razmeschenie(s:string;k:word;povtor:boolean):tstrings;
var p:pboolean;
    c:string;
    strlist:tstringlist;
 procedure proced(zn,dl:word);
 var w:integer;
 begin
    for w:=1 to length(s) do
    if (p^)or((not p^)and(pos(s[w],copy(c,1,zn-1))=0)) then
    begin
        c[zn]:=s[w];
        if zn<dl then proced(zn+1,dl);
        if zn=dl then strlist.Add(c);
    end;
 end;
begin
strlist:=tstringlist.Create;
strlist.Clear;
new(p);
if k<=length(s) then p:=@povtor else p^:=true;
setlength(c,k);
proced(1,k);
result:=strlist;
end;

function perestanovka(s:string):tstrings;
begin
result:=razmeschenie(s,length(s),false);
end;

function normalize(s:string):string;
var ss:string;
     n:longword;
begin
if s='' then
 begin
  result:=s;
  exit;
 end;
n:=1;
ss:=s;
while n<=length(ss) do
  begin
    while pos(ss[n],copy(ss,n+1,length(ss)))>0 do delete(ss,n+pos(ss[n],copy(ss,n+1,length(ss))),1);
    inc(n);
  end;
result:=ss;
end;


И, как последствие из комбинаторики, хочу привести функцию перебора паролей. Где line - строка (символы не должны повторяться), len - длина пароля, minlen - выдать также пароли длиной от 1 до len.

Код

function passwords(const line:string;len:word;minlen:boolean):Tstrings;
var c:string;
    i:word;
    strlist:tstringlist;
 procedure proced(zn,dl:word);
 var w:integer;
 begin
   for w:=1 to length(line) do
   begin
     c[zn]:=line[w];
     if zn<dl then proced(zn+1,dl);
     if zn=dl then strlist.Add(c);
   end;
 end;
begin
strlist:=tstringlist.Create;
strlist.Clear;
if minlen then
   for i:=1 to len do
      begin
        c:='';
        setlength(c,i);
        proced(1,i);
      end
      else begin
        setlength(c,len);
        proced(1,len);
      end;
result:=strlist;
end;


Все применение в прилагаемом файле.
ЗЫ: По вопросам и предложениям пишите в ПМ

Автор: Yanis 13.10.2006, 10:09
Добавление иконки в стандартный MessageBox (используется MessageBoxIndirect)
Цитата(Yanis @ 13.10.2006,  00:14)
Код
function MessageBoxIndirect(const MsgBoxParams: TMsgBoxParams): Integer; stdcall; external user32 name 'MessageBoxIndirectA';

function MessageBoxWithIcon(hWnd: HWND; const lpText, lpCaption: string; uType: DWORD; szIcon: PWChar): Integer;
var
  mbp: TMsgBoxParams;
begin
  ZeroMemory(@mbp, SizeOf(mbp));
  with mbp do
    begin
      cbSize := SizeOf(mbp);
      hwndOwner := hWnd;
      hInstance := SysInit.HInstance;
      lpszText := PChar(lpText);
      lpszCaption := PChar(lpCaption);
      PWChar(lpszIcon) := szIcon;
      dwStyle := uType;
    end;

  Result := MessageBoxIndirect(mbp);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MessageBoxWithIcon(Handle, 'Привет', 'Сообщение с иконкой!', MB_USERICON or MB_APPLMODAL, 'MAINICON');
end;


Добавлено @ 23:16 
Пришлось экспортировать функцию MessageBoxIndirectA самостоятельно т.к. в модуле Windows она неправильно объявлена.
Если нет желания импортировать, то можно изменить последнюю строчку функции на такую:
Код
Result := Integer(MessageBoxIndirect(mbp));
http://forum.vingrad.ru/index.php?showtopic=116210&view=findpost&p=886953


Добавление собственных компонентов с [B]MessageBox. Другой подход, с использованием ловушек.[/B]
Цитата(Yanis @ 13.10.2006,  10:40)
Цитата(aktuba @  13.10.2006,  09:59 Найти цитируемый пост)
А какие книги посоветуешь? Я, так понимаю, что-то по устройству Windows? Можешь дать названия? 

Вот ещё один способ добавления элемента управления в MessageBox:
Код
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  g_hHook: HHOOK;
  g_oldProc: Pointer = nil;
  g_bChecked: Boolean = False;
  g_cb: TCheckBox;
  g_szCbCaption: string = '';

const
  IDC_CHECKBOX = 1000;

implementation

{$R *.dfm}

// узнаём ширину текста для контекста (HDC) определённого окна (hWnd)
function GetTextWidth(hWnd: HWND; const szCaption: string): Integer;
var
  Res: TSize;
begin
  ZeroMemory(@Res, SizeOf(Res));
  GetTextExtentPoint32(GetWindowDC(hWnd), PChar(szCaption), Length(szCaption), Res);
  Result := Res.cx;
end;

function MyMessageBox(hWnd: HWND; const szText, szCaption, szCheckBoxCaption: string; uType: UINT): Integer;
begin
  g_szCbCaption := szCheckBoxCaption;
  Result := MessageBox(hWnd, PChar(szText), PChar(szCaption), uType);
end;

procedure CreateCheckBox(hWndOwner: HWND);
begin
  g_cb := TCheckBox.Create(Application);
  with g_cb do
    begin
      ParentWindow := hWndOwner;
      g_cb.Caption := g_szCbCaption;
      Checked := True;
      g_cb.Width := GetTextWidth(g_cb.Handle, g_szCbCaption);
      SetWindowLong(Handle, GWL_ID, IDC_CHECKBOX);
    end;
end;

procedure UnInstallHook(m_gHook: HHOOK);
begin
    // Uninstall the hook
    UnhookWindowsHookEx(m_gHook);
end;

function SetOut: Boolean;
begin
  g_cb.Checked := not g_cb.Checked;
end;

function HookWndProc(hWnd: HWND; uMsg, wParam, lParam: Integer): Integer; stdcall;
var
  nRc: Integer;
begin
  // дадим ОС обработать основные операции
  nRc := CallWindowProc(g_oldProc, hWnd, uMsg, wParam, lParam);

  // если диалог хочет загрузиться, то...
  if (uMsg = WM_INITDIALOG) then
      begin
      // создаём на нём кнопку
      CreateCheckBox(hWnd);
    end;

  // если кликнули по checkbox-у
  // на это указывает его nID
    if (uMsg = WM_COMMAND) and (wParam = IDC_CHECKBOX) then
    SetOut; // обрабатываем нажатие на checkbox

  // если диалог уничтожается, то...
    if (uMsg = WM_NCDESTROY) then
    begin
        UnInstallHook(g_hHook);
      FreeAndNil(g_cb);
    end;

  Result := nRc;
end;

// функция ловушки нашего приложения
function SetHook(nCode, wParam, lParam: Integer): Integer; stdcall;
var
  M: TCWPStruct;
begin
  if (nCode = HC_ACTION) then
    begin
      M := TCWPStruct(Pointer(lParam)^);

      // если нам пришло сообщение, что сейчас будет создан checkbox, то ....
      if M.message = WM_INITDIALOG then
        g_oldProc := Pointer(SetWindowLong(M.hwnd, GWL_WNDPROC, Integer(@HookWndProc)));
    end;

  Result := CallNextHookEx(g_hHook, nCode, wParam, lParam);
end;

// устанавливаем ловушку на все сообщения, которые
// предназначаются оконной процедуре
// мы будем их обрабатывать перед оконной процедурой
function InstallHook: HHOOK;
begin
    g_hHook := SetWindowsHookEx(WH_CALLWNDPROC,
                              @SetHook, // процедура обработки ловушки
                              0,
                              GetCurrentThreadId()); // ассоциируем ловушку с текущим (потоком нешего окна) потоком
  Result := g_hHook;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  InstallHook;
  MyMessageBox(Handle, 'Исходные данные будут перезаписаны!', 'Продолжить?', 'Больше не предупреждать меня', MB_ICONQUESTION or MB_YESNO)
end;

end.


Изменение расположения CheckBox оставляю на тебя. Заодно и по коду пробежишься. Комменты имеются.
http://forum.vingrad.ru/index.php?showtopic=116210&view=findpost&p=887225

Автор: Akella 19.10.2006, 13:21
FireBird SQL Server + C#

выборка из одной таблицы
Код

string mySelectQuery = "select a.id, r.name from apart a left join regions r on (r.id = a.id_regions)";
myConnection.Open();
FbDataAdapter da = new FbDataAdapter(mySelectQuery, myConnection);
FbCommand comm = new FbCommand(mySelectQuery);
DataSet ds = new DataSet("regions");
da.Fill(ds, "regions");
DataTable dt = ds.Tables["regions"];
dataGridView1.DataSource = dt;


выборка из двух таблиц
Код

string mySelectQuery = "select a.id, r.name from apart a left join regions r on (r.id = a.id_regions)";
myConnection.Open();
FbDataAdapter da = new FbDataAdapter(mySelectQuery, myConnection);
FbCommand comm = new FbCommand(mySelectQuery);
DataSet ds = new DataSet();
da.Fill(ds);
DataTable dt = ds.Tables[0];
dataGridView1.DataSource = dt;

Автор: Snowy 19.10.2006, 13:28
Akella, а какое отношение C# имеет к DRKB?

Автор: Akella 19.10.2006, 15:29
Отлавливаем нажатие клавишь в OnKeyDown (кто-то говорил, что в OnKeyDown мона только впоймать только служебные клавиши, типа VK_RETURN или VK_F1)
Код

//отлавливаем Ctrl+F, чтобы включить контекстный поиск грида
//а т.к. может быть не только английская, но и русская раскладка, то нужно отлавливать ещё и русские 'А' и 'а'
//ловим нажатие обеих регистров, т.е. и 'F', и 'f
  if ((ssCtrl in Shift) and (key in [Ord('F'),Ord('f'),Ord('А'),Ord('а')])) then begin
    dbgArrivalDet.OptionsBehavior.IncSearch := true;
    dbgArrivalDet.OptionsBehavior.IncSearchItem := dbgArrivalDet.Controller.FocusedColumn;
  end;
//просто для справки: dbgArrivalDet - cxGrid (DevExpress)


Добавлено @ 15:31 
вот это (редактор колонок для DBGridEh)
http://forum.vingrad.ru/index.php?showtopic=114799&view=findpost&p=876524

то же самое, только используем контекстные меню
http://forum.vingrad.ru/index.php?showtopic=114799&view=findpost&p=885300

Добавлено @ 15:37 
Цитата
Akella, а какое отношение C# имеет к DRKB? 

да ,точно, не сообоазил чётта что Delphi Rassian Knowlage Base 

Автор: Akella 23.10.2006, 10:56
Работа с колонтитулами в Excel
http://forum.vingrad.ru/act-ST/f-89/t-117773/unread-1.html

Добавлено @ 11:01 
Шрифты и цвета в Excel
http://forum.vingrad.ru/act-ST/f-89/t-117775/unread-1.html

Автор: Romikgy 23.10.2006, 11:06
Цитата(Akella @  19.10.2006,  14:29 Найти цитируемый пост)
Отлавливаем нажатие клавишь в OnKeyDown (кто-то говорил, что в OnKeyDown мона только впоймать только служебные клавиши, типа VK_RETURN или VK_F1)

имхо здесь немного с избыточностью, т.к. в онкейдауне в кее виртуальная кнопка, а она и для больших и для маленьких и вообще для всех раскладок одинакова, вот файлик с инклюдом всех виртуальных кодов ,
использование 
добавляем такую вещь
{$I virtual_key.inc}
и юзаем везде по коду VK_RETURN , VK_F 
Цитата(Akella @  19.10.2006,  14:29 Найти цитируемый пост)
 if ((ssCtrl in Shift) and (key in [Ord('F'),Ord('f'),Ord('А'),Ord('а')])) then begin

и условие для контрл F 
Код

if ((ssCtrl in Shift) and (key in [VK_F ])) then begin

или 
Код

if ((ssCtrl in Shift) and (key=VK_F )) then begin

Автор: Akella 23.10.2006, 11:07
Нраницы и перенос по словам в Excel
http://forum.vingrad.ru/topic-117776.html

Автор: TopSergey 25.10.2006, 23:17
Я слыхал тут отбор тем для нового  DRKB. Вот, нашёл интересную вещь. В предыдущих версиях DRKB не встречал. 

Называется: Как использовать CHM Help файлы в Delphi.

Код

unit HtmlHelp;

interface

uses
  Windows, Graphics;

const
  HH_DISPLAY_TOPIC = $0000;
  HH_DISPLAY_TOC = $0001;
  HH_DISPLAY_INDEX = $0002;
  HH_DISPLAY_SEARCH = $0003;
  HH_SET_WIN_TYPE = $0004;
  HH_GET_WIN_TYPE = $0005;
  HH_GET_WIN_HANDLE = $0006;
  HH_GET_INFO_TYPES = $0007;
  HH_SET_INFO_TYPES = $0008;
  HH_SYNC = $0009;
  HH_ADD_NAV_UI = $000A;
  HH_ADD_BUTTON = $000B;
  HH_GETBROWSER_APP = $000C;
  HH_KEYWORD_LOOKUP = $000D;
  HH_DISPLAY_TEXT_POPUP = $000E;
  HH_HELP_CONTEXT = $000F;

const
  HHWIN_PROP_ONTOP = 2;
  HHWIN_PROP_NOTITLEBAR = 4;
  HHWIN_PROP_NODEF_STYLES = 8;
  HHWIN_PROP_NODEF_EXSTYLES = 16;
  HHWIN_PROP_TRI_PANE = 32;
  HHWIN_PROP_NOTB_TEXT = 64;
  HHWIN_PROP_POST_QUIT = 128;
  HHWIN_PROP_AUTO_SYNC = 256;
  HHWIN_PROP_TRACKING = 512;
  HHWIN_PROP_TAB_SEARCH = 1024;
  HHWIN_PROP_TAB_HISTORY = 2048;
  HHWIN_PROP_TAB_FAVORITES = 4096;
  HHWIN_PROP_CHANGE_TITLE = 8192;
  HHWIN_PROP_NAV_ONLY_WIN = 16384;
  HHWIN_PROP_NO_TOOLBAR = 32768;

const
  HHWIN_PARAM_PROPERTIES = 2;
  HHWIN_PARAM_STYLES = 4;
  HHWIN_PARAM_EXSTYLES = 8;
  HHWIN_PARAM_RECT = 16;
  HHWIN_PARAM_NAV_WIDTH = 32;
  HHWIN_PARAM_SHOWSTATE = 64;
  HHWIN_PARAM_INFOTYPES = 128;
  HHWIN_PARAM_TB_FLAGS = 256;
  HHWIN_PARAM_EXPANSION = 512;
  HHWIN_PARAM_TABPOS = 1024;
  HHWIN_PARAM_TABORDER = 2048;
  HHWIN_PARAM_HISTORY_COUNT = 4096;
  HHWIN_PARAM_CUR_TAB = 8192;

const
  HHWIN_BUTTON_EXPAND = 2;
  HHWIN_BUTTON_BACK = 4;
  HHWIN_BUTTON_FORWARD = 8;
  HHWIN_BUTTON_STOP = 16;
  HHWIN_BUTTON_REFRESH = 32;
  HHWIN_BUTTON_HOME = 64;
  HHWIN_BUTTON_BROWSE_FWD = 128;
  HHWIN_BUTTON_BROWSE_BCK = 256;
  HHWIN_BUTTON_NOTES = 512;
  HHWIN_BUTTON_CONTENTS = 1024;
  HHWIN_BUTTON_SYNC = 2048;
  HHWIN_BUTTON_OPTIONS = 4096;
  HHWIN_BUTTON_PRINT = 8192;
  HHWIN_BUTTON_INDEX = 16384;
  HHWIN_BUTTON_SEARCH = 32768;
  HHWIN_BUTTON_HISTORY = 65536;
  HHWIN_BUTTON_FAVORITES = 131072;
  HHWIN_BUTTON_JUMP1 = 262144;
  HHWIN_BUTTON_JUMP2 = 524288;
  HHWIN_BUTTON_ZOOM = HHWIN_Button_Jump2 * 2;
  HHWIN_BUTTON_TOC_NEXT = HHWIN_Button_Zoom * 2;
  HHWIN_BUTTON_TOC_PREV = HHWIN_Button_Toc_Next * 2;

const
  HHWIN_DEF_Buttons = HHWIN_Button_Expand or HHWIN_Button_Back or
    HHWIN_Button_Options or HHWIN_Button_Print;

const
  IDTB_EXPAND = 200;
  IDTB_CONTRACT = 201;
  IDTB_STOP = 202;
  IDTB_REFRESH = 203;
  IDTB_BACK = 204;
  IDTB_HOME = 205;
  IDTB_SYNC = 206;
  IDTB_PRINT = 207;
  IDTB_OPTIONS = 208;
  IDTB_FORWARD = 209;
  IDTB_NOTES = 210;
  IDTB_BROWSE_FWD = 211;
  IDTB_BROWSE_BACK = 212;
  IDTB_CONTENTS = 213;
  IDTB_INDEX = 214;
  IDTB_SEARCH = 215;
  IDTB_HISTORY = 216;
  IDTB_FAVORITES = 217;
  IDTB_JUMP1 = 218;
  IDTB_JUMP2 = 219;
  IDTB_CUSTOMIZE = 221;
  IDTB_ZOOM = 222;
  IDTB_TOC_NEXT = 223;
  IDTB_TOC_PREV = 224;

const
  HHN_First = Cardinal(-860);
  HHN_Last = Cardinal(-879);

  HHN_NavComplete = HHN_First - 0;
  HHN_Track = HHN_First - 1;

type
  HHN_Notify = record
    hdr: Pointer;
    pszUrl: PWideChar;
  end;

  HH_Popup = record
    cbStruct: Integer;
    hinst: THandle;
    idString: Cardinal;
    pszText: PChar;
    pt: TPoint;
    clrForeground: TColor;
    clrBackground: TColor;
    rcMargins: TRect;
    pszFont: PChar;
  end;

  HH_AKLINK = record
    cbStruct: Integer;
    fReserved: bool;
    pszKeywords: PChar;
    pszUrl: PChar;
    pszMsgText: PChar;
    pszMsgTitle: PChar;
    pszWindow: PChar;
    fIndexOnFail: bool;
  end;

type
  HHWin_NavTypes = (HHWIN_NAVTYPE_TOC,
    HHWIN_NAVTYPE_INDEX,
    HHWIN_NAVTYPE_SEARCH,
    HHWIN_NAVTYPE_HISTORY,
    HHWIN_NAVTYPE_FAVOURITES);

type
  HH_InfoType = Longint;
  PHH_InfoType = ^HH_InfoType;

type
  HHWin_NavTabs = (HHWIN_NavTab_Top,
    HHWIN_NavTab_Left,
    HHWIN_NavTab_Bottom);

const
  HH_Max_Tabs = 19;

type
  HH_Tabs = (HH_TAB_CONTENTS,
    HH_TAB_INDEX,
    HH_TAB_SEARCH,
    HH_TAB_HISTORY,
    HH_TAB_FAVORITES
    );

const
  HH_FTS_DEFAULT_PROXIMITY = (-1);

type
  HH_FTS_Query = record
    cbStruct: Integer;
    fUniCodeStrings: bool;
    pszSearchQuery: PChar;
    iProximity: Longint;
    fStemmedSearch: bool;
    fTitleOnly: bool;
    fExecute: bool;
    pszWindow: PChar;
  end;

type
  HH_WinType = record
    cbStruct: Integer;
    fUniCodeStrings: bool;
    pszType: PChar;
    fsValidMembers: Longint;
    fsWinProperties: Longint;
    pszCaption: PChar;
    dwStyles: Longint;
    dwExStyles: Longint;
    rcWindowPos: TRect;
    nShowState: Integer;
    hwndHelp: THandle;
    hwndCaller: THandle;
    paInfoTypes: ^HH_InfoType;
    hwndToolbar: THandle;
    hwndNavigation: THandle;
    hwndHTML: THandle;
    iNavWidth: Integer;
    rcHTML: TRect;
    pszToc: PChar;
    pszIndex: PChar;
    pszFile: PChar;
    pszHome: PChar;
    fsToolbarFlags: Longint;
    fNotExpanded: bool;
    curNavType: Integer;
    tabPos: Integer;
    idNotify: Integer;
    TabOrder: array[0..HH_Max_Tabs + 1] of Byte;
    cHistory: Integer;
    pszJump1: PChar;
    pszJump2: PChar;
    pszUrlJump1: PChar;
    pszUrlJump2: PChar;
    rcMinSize: TRect;
  end;

  PHH_WinType = ^HH_WinType;

type
  HHACTTYpes = (HHACT_TAB_CONTENTS,
    HHACT_TAB_INDEX,
    HHACT_TAB_SEARCH,
    HHACT_TAB_HISTORY,
    HHACT_TAB_FAVORITES,

    HHACT_EXPAND,
    HHACT_CONTRACT,
    HHACT_BACK,
    HHACT_FORWARD,
    HHACT_STOP,
    HHACT_REFRESH,
    HHACT_HOME,
    HHACT_SYNC,
    HHACT_OPTIONS,
    HHACT_PRINT,
    HHACT_HIGHLIGHT,
    HHACT_CUSTOMIZE,
    HHACT_JUMP1,
    HHACT_JUMP2,
    HHACT_ZOOM,
    HHACT_TOC_NEXT,
    HHACT_TOC_PREV,
    HHACT_NOTES,

    HHACT_LAST_ENUM
    );

type
  HHNTRACK = record
    hdr: TNMHDR;
    pszCurUrl: PWideChar;
    idAction: Integer;
    phhWinType: ^HH_WinType;
  end;
  PHHNTRACK = ^HHNTRACK;

  HHNNAVCOMPLETE = record
    hdr: TNMHDR;
    pszUrl: PChar;
  end;
  PHHNNAVCOMPLETE = ^HHNNAVCOMPLETE;

type
  THtmlHelpA = function(hwndCaller: THandle; pszFile: PChar;
    uCommand: Cardinal; dwData: Longint): THandle;
  stdCall;
  THtmlHelpW = function(hwndCaller: THandle; pszFile: PChar;
    uCommand: Cardinal; dwData: Longint): THandle;
  stdCall;

function HH(hwndCaller: THandle; pszFile: PChar; uCommand: Cardinal;
  dwData: Longint): THandle;
function HtmlHelpInstalled: Boolean;

implementation

const
  ATOM_HTMLHELP_API_ANSI = #14#0;
ATOM_HTMLHELP_API_UNICODE = #15#0;

var
HtmlHelpA: THtmlHelpA;
  OCXHandle: THandle;

function HH;
begin
  Result := 0;
  if (Assigned(HtmlHelpA)) then
  begin
    Result := HtmlHelpA(hwndCaller, pszFile, uCommand, dwData);
  end;
end;

function HtmlHelpInstalled: Boolean;
begin
  Result := (Assigned(HtmlHelpA));
end;

initialization
  begin
    HtmlHelpA := nil;
    OCXHandle := LoadLibrary('HHCtrl.OCX');
    if (OCXHandle <> 0) then
    begin
      HtmlHelpA := GetProcAddress(OCXHandle, 'HtmlHelpA');
    end;
  end;

finalization
  begin
    if (OCXHandle <> 0) then
      FreeLibrary(OCXHandle);
  end;
end.
//-----------------------------------------------

unit Unit1;

{....}

implementation

uses
  HtmlHelp;

const
  HH_HELP_CONTEXT = $F;
  MYHELP_FILE = 'DualHelp.chm' + Chr(0);
var
  RetCode: LongInt;

{$R *.DFM}

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = vk_f1 then
  begin
    if HtmlHelpInstalled = True then
    begin
      RetCode := HH(Form1.Handle, PChar(MYHELP_FILE), HH_HELP_CONTEXT,
        ActiveControl.HelpContext);
      Key := 0; //eat it!
    end
    else
      helpfile := 'hhtest.hlp';
  end;
end;

Автор: Snowy 25.10.2006, 23:28
TopSergey, есть уже.
В разделе "Разработка приложений -> Работа со справочной системой"
Не этот же код, но аналогичный.

Автор: Snowy 26.10.2006, 23:03
Не знаю, стоит ли одна строчка места в DRKB...
Как определить язык Windows?
То есть какая винда: русская/английская/еврейская etc
Код

function GetSystemDefaultUILanguage: UINT; stdcall; external kernel32 name 'GetSystemDefaultUILanguage';
function GetSysLang: integer;
begin
  result :=   Lo(GetSystemDefaultUILanguage);
end;
Функция GetSysLang возвращает язык системы.
Таблица языков есть в MSDN.
Но на всякий случай привожу тут:
Цитата

00 - LANG_NEUTRAL - Neutral
01 - LANG_ARABIC - Arabic
02 - LANG_BULGARIAN - Bulgarian
03 - LANG_CATALAN - Catalan
04 - LANG_CHINESE - Chinese
05 - LANG_CZECH - Czech
06 - LANG_DANISH - Danish
07 - LANG_GERMAN - German
08 - LANG_GREEK - Greek
09 - LANG_ENGLISH - English
0a - LANG_SPANISH - Spanish
0b - LANG_FINNISH - Finnish
0c - LANG_FRENCH - French
0d - LANG_HEBREW - Hebrew
0e - LANG_HUNGARIAN - Hungarian
0f - LANG_ICELANDIC - Icelandic
10 - LANG_ITALIAN - Italian
11 - LANG_JAPANESE - Japanese
12 - LANG_KOREAN - Korean
13 - LANG_DUTCH - Dutch
14 - LANG_NORWEGIAN - Norwegian
15 - LANG_POLISH - Polish
16 - LANG_PORTUGUESE - Portuguese
18 - LANG_ROMANIAN - Romanian
19 - LANG_RUSSIAN - Russian
1a - LANG_CROATIAN - Croatian
1a - LANG_SERBIAN - Serbian
1b - LANG_SLOVAK - Slovak
1c - LANG_ALBANIAN - Albanian
1d - LANG_SWEDISH - Swedish
1e - LANG_THAI - Thai
1f - LANG_TURKISH - Turkish
20 - LANG_URDU - Urdu 
21 - LANG_INDONESIAN - Indonesian
22 - LANG_UKRAINIAN - Ukrainian
23 - LANG_BELARUSIAN - Belarusian
24 - LANG_SLOVENIAN - Slovenian
25 - LANG_ESTONIAN - Estonian
26 - LANG_LATVIAN - Latvian
27 - LANG_LITHUANIAN - Lithuanian
29 - LANG_FARSI - Farsi
2a - LANG_VIETNAMESE - Vietnamese
2b - LANG_ARMENIAN - Armenian
2c - LANG_AZERI - Azeri
2d - LANG_BASQUE - Basque
2f - LANG_MACEDONIAN - FYRO - Macedonian
36 - LANG_AFRIKAANS - Afrikaans
37 - LANG_GEORGIAN - Georgian
38 - LANG_FAEROESE - Faeroese
39 - LANG_HINDI - Hindi
3e - LANG_MALAY - Malay
3f - LANG_KAZAK - Kazak
40 - LANG_KYRGYZ - Kyrgyz
41 - LANG_SWAHILI - Swahili
43 - LANG_UZBEK - Uzbek
44 - LANG_TATAR - Tatar
45 - LANG_BENGALI - Not - supported.
46 - LANG_PUNJABI - Punjabi
47 - LANG_GUJARATI - Gujarati
48 - LANG_ORIYA - Not - supported.
49 - LANG_TAMIL - Tamil
4a - LANG_TELUGU - Telugu
4b - LANG_KANNADA - Kannada
4c - LANG_MALAYALAM - Not - supported.
4d - LANG_ASSAMESE - Not - supported.
4e - LANG_MARATHI - Marathi
4f - LANG_SANSKRIT - Sanskrit
50 - LANG_MONGOLIAN - Mongolian
56 - LANG_GALICIAN - Galician
57 - LANG_KONKANI - Konkani
58 - LANG_MANIPURI - Not - supported.
59 - LANG_SINDHI - Not - supported.
5a - LANG_SYRIAC - Syriac
60 - LANG_KASHMIRI - Not - supported.
61 - LANG_NEPALI - Not - supported.
65 - LANG_DIVEHI - Divehi


Добавлю. Нашёл в DRKB топ "Как определить локализацию ОС: английская или русская?"
Это решение неверное - оно говорит о том, какой язык дефолтный, но не определяет локализацию.
Правильный данный пример smile

Автор: Akella 27.10.2006, 08:04
Отлавливаем утечки памяти. 
При запуске главной формы включаем "ловушку".
По завершению приложения, если запуск был из под IDE, будет показано окошко с модулями, где есть утечка памяти.
Код

procedure TfmMain.FormCreate(Sender: TObject);
begin
//отлавливаем утечки памяти
  ReportMemoryLeaksOnShutdown := DebugHook <> 0;
end;

Автор: Addmin 30.10.2006, 17:40
У меня есть работа на тему "Продажа программ за рубеж". Большая такая, поэтапная. На книжку тянет (правда, её ещё надо доработать). Чисто о программировании там - ни строчки. Больше менеджментского.

Такая в DKRB пойдёт?  

Автор: Vit 30.10.2006, 19:11
Цитата(Addmin @  30.10.2006,  08:40 Найти цитируемый пост)
Такая в DKRB пойдёт?   


Да

Автор: Addmin 31.10.2006, 11:12
Ммм... Нашёл сообщение об FTP-архивчике...

Мой первый взнос:

PE Optimizer 1.2 от Dr. Golova: 

Думаю, все слышали о StripReloc Джордана Рассела. Она занимается тем, что вырезает релоки из PE-файлов. Но мало кто знает о PE Optimizer. А между тем это очень маленькая и удобная утилита. Возможности (цитирую автора):

Цитата

1) Из файла вырезаются релоки, абсолютно не нужные в exe файлах.
2) Уменьшается выравнивание PE заголовка до минимально безопасного значения
(16 байт) и вычищается весь мусор из заголовка.
3) Уменьшается  выравнивание  всех  секций  и  заголовка  до   минимального
безопасного значения (200h байт), тем самым из файла удаляются   все пустые
секции.  Удаляется  только  их  присутствие  в файле, из заголовка запись о
секции не вырезается, так что после загрузки файла в память, он будет такой
же как до оптимизации.


И, что немаловажно (в крайнем случае для меня), она, в отличии от StripReloc, имеет GUI.

В результате файл уменьшается примерно на 5 %. Для программ, больше 500 Кб это уже видимый результат.

Данная версия самая новая (15.10.2001 smile ) и, очевидно, последняя.

P.S. Имеется платный аналог - PE Corrector. Стоит 40 $, а результат - точно такой же (Правда, он ещё умеет вырезать Debug-информацию, но это можно уже в самой Delphi задать)  

P.P.S. Исходники на Delphi - прилагаются.

Автор: Snowy 2.11.2006, 02:24
На будущее может пригодиться.
На будущее, потому что совместимость WinXP и выше.

Конвертация в Base64 средствами WinAPI.
http://forum.vingrad.ru/index.php?showtopic=119333&view=findpost&p=908724
Авторство: Snowy, dumb.
Живых примеров нет даже у гугля.

Автор: Addmin 4.11.2006, 05:42
А какой формат статьи требуется для DRKB Explorer? Простые HTML или ещё что?

Автор: Quadr0 6.11.2006, 15:22
...

Автор: Vit 6.11.2006, 16:19
Цитата(Addmin @  3.11.2006,  20:42 Найти цитируемый пост)
А какой формат статьи требуется для DRKB Explorer? Простые HTML или ещё что? 


Мне легче всего работать с Word или rtf, можно html или просто текст, хуже всего с pdf

Автор: Insert 6.11.2006, 21:01
Имеются некоторые знания по работе с pdf файлами, точнее с ихними внутренностями(структура, теги,обьекты),методы доступа к ним, если надо могу статейку накатать, только сроки скажите.

Автор: Quadr0 6.11.2006, 21:41
...

Автор: Insert 6.11.2006, 23:01
Ну буду рад помочь, но так как это будет моя первая статья такого плана, то  надеюсь с вашей помощью, сделаю её читабельной и понятной.
ЗЫ:
 Также если интересует формат XPS(альтернатива pdf, созданная MS, выйдет вместе в Vistoй) тоже можно сделать небольшое ознакомление со структурой, тут уж информации в сети практически нету, все из SDK беты из самостоятельного изучения. Но это так по желанию. В реале этот формат войдет в силу и станет популярным( а он станет популярным ) только через год - полтора после выхода Висты, так что это так на будущее.

Автор: Vit 7.11.2006, 15:28
Цитата(Insert @  6.11.2006,  12:01 Найти цитируемый пост)
Имеются некоторые знания по работе с pdf файлами, точнее с ихними внутренностями(структура, теги,обьекты),методы доступа к ним, если надо могу статейку накатать, только сроки скажите. 



Ух ты! Должна быть очень полезная инфа

Автор: Akella 8.11.2006, 10:05
Цитата(Insert @  6.11.2006,  21:01 Найти цитируемый пост)
Имеются некоторые знания по работе с pdf файлами, точнее с ихними внутренностями(структура, теги,обьекты),методы доступа к ним, если надо могу статейку накатать, только сроки скажите. 

Только не в PDF. smile 
Мы сейчас обрабатываем кучу документации - переводим из англ. на русский - это ужас. только не в PDF.

Автор: Albinos_x 8.11.2006, 17:16
переделал статью, но только пока про компоненту TWordApplication...  в формате Word подойдёт?

Автор: Vit 8.11.2006, 18:12
Цитата(Albinos_x @  8.11.2006,  08:16 Найти цитируемый пост)
в формате Word подойдёт?


Да

Автор: Albinos_x 8.11.2006, 20:27
прикрепляю файл...

Добавлено @ 20:33 
в документе 24 страницы... я там ещё кое чего добавил, чего нет в статье на форуме...

Автор: Albinos_x 9.11.2006, 01:55
Прикрепляю отредактированную статью по компаненте ExcelApplication ...

Она возможно ещё подвергнется редактированию... но это только тогда, когда появится свободное время, аего в ближайшее время пока не предвидится... smile 

в документе 18 стр.

Автор: tripsin 9.11.2006, 14:23
 Посмотрите. Может что-то http://tripsin.narod.ru/articles.htm сгодится.

Автор: Rodman 14.11.2006, 22:05
Вот пример вывода данных (на примере XML, так же присутствует пример простейшего парсинга XML'я) в TDBGrid...

Но единственное примечание - требуется компонент из http://sourceforge.net/projects/jvcl (или подобный)...

Автор: Rodman 15.11.2006, 17:33
И вот еще коварный вопрос по базам. С рудом нашел. В старой версии DRKB такого нет...

Может  пригодиться:
- создание Базы Access
Код

procedure CreateMSAccessDB(filename : String);
var
  DBEngine, Workspace: Variant;
const
  {Important to use the following constant as is}
  dbLangGeneral = ';LANGID=0x0409;CP=1252;COUNTRY=0';
  dbVersion30 = 64;
begin
if not FileExists(FileName+'.mdb') then begin
  //DBEngine := CreateOleObject('DAO.DBEngine');
  DBEngine := CreateOleObject('DAO.DBEngine.36'); //For DAO 3.5
  Workspace := DBEngine.Workspaces[0];
  try
    Workspace.CreateDatabase(filename, dbLangGeneral, dbVersion30);
  except on EOleException do
    ShowMessage('Невозможно создать!');
  end;
  end;
end;


- вывод количества таблиц в базе
Код

t:Tstringlist; 
... 
ADOConnection.GetTableNames(t, false);

Автор: Vit 15.11.2006, 18:52
Цитата(Rodman @  15.11.2006,  08:33 Найти цитируемый пост)
 вот еще коварный вопрос по базам. С рудом нашел. В старой версии DRKB такого нет...



Или версия совсем уж старая или плохо смотрели, есть такое...

Автор: Alex 15.11.2006, 21:34
Цитата(Akella @ 27.10.2006,  09:04)
Отлавливаем утечки памяти. 
При запуске главной формы включаем "ловушку".
По завершению приложения, если запуск был из под IDE, будет показано окошко с модулями, где есть утечка памяти.
Код

procedure TfmMain.FormCreate(Sender: TObject);
begin
//отлавливаем утечки памяти
  ReportMemoryLeaksOnShutdown := DebugHook <> 0;
end;

только не нужно это в таком виде включать в DRKB smile  Точнее код правильный, но описание к нему должно быть другим. Это код будет работать во все Delphi начиная с BDS2006 и в случаи утечек просто будет сообщения, что они есть без указания конкретных модулей. Для получения информации в каком модуле происходит утечка можно воспользоваться бесплатной библиотекой http://fastmm.sourceforge.net

Добавлено @ 21:43 
http://alex-co.com.ru/delphi/Documents/Papers/StringInDelphi.php

PS: Могу отдать как doc файл, если его проще будет вставлять в DRKB

Автор: Snowy 16.11.2006, 02:15

M
Snowy		Просьба, размещающим материал. 
Если вы не являетесь его автором, то указывайте авторство  :exclamation

Автор: Elfebet 17.11.2006, 17:11
Удаление HTML елементов из тектса. в ДРКБ есть данная тема, но приведенная функция при больших объемах файла (если уже больше 100кб!) просто зависает, а данная функция просто летает (html файл размером 14,1 мб (!!!) обработал за 0,577 секунд)
Код

function ConvertHTML(s: String): String;
var
  InTeg, InScript, InLink, InStyle:Boolean;
  i, j, len, NotInTegC: Integer;
begin
  len:=Length(s);
  NotInTegC:=0;
  InTeg:=False;
  InScript:=False;
  InLink:=False;
  InStyle:=False;
  SetLength(Result, len);
  for i:=1 to len do begin
    if (s[i]='<') and
       ((s[i+1]='b')or(s[i+1]='B'))and
       ((s[i+2]='o')or(s[i+2]='O'))and
       ((s[i+3]='d')or(s[i+3]='D'))and
       ((s[i+4]='y')or(s[i+4]='Y'))and
       ((s[i+5]=' ')or(s[i+5]='>'))then Break;
  end;
  for j:=i to len do begin
    if (s[j]='<') and
       ((s[j+1]='s')or(s[j+1]='S'))and
       ((s[j+2]='c')or(s[j+2]='C'))and
       ((s[j+3]='r')or(s[j+3]='R'))and
       ((s[j+4]='i')or(s[j+4]='I'))and
       ((s[j+5]='p')or(s[j+5]='P'))and
       ((s[j+6]='t')or(s[j+6]='T'))and
       ((s[j+7]=' ')or(s[j+7]='>'))then InScript:=True
    else if InScript and (s[j-8]='<')and(s[j-7]='/')and
       ((s[j-6]='s')or(s[j-6]='S'))and
       ((s[j-5]='c')or(s[j-5]='C'))and
       ((s[j-4]='r')or(s[j-4]='R'))and
       ((s[j-3]='i')or(s[j-3]='I'))and
       ((s[j-2]='p')or(s[j-2]='P'))and
       ((s[j-1]='t')or(s[j-1]='T'))and
       (s[j]='>')then begin InScript:=False; Continue; end;
    if (s[j]='<')and
       ((s[j+1]='a')or(s[j+1]='A'))and
       (s[j+2]=' ')then InLink:=True
    else if InLink and (s[j-3]='<')and(s[j-2]='/')and
       ((s[j-1]='a')or(s[j-1]='A'))and
       (s[j]='>')then begin InLink:=False; Continue; end;
    if (s[j]='<') and
       ((s[j+1]='s')or(s[j+1]='S'))and
       ((s[j+2]='t')or(s[j+2]='T'))and
       ((s[j+3]='y')or(s[j+3]='Y'))and
       ((s[j+4]='l')or(s[j+4]='L'))and
       ((s[j+5]='e')or(s[j+5]='E'))and
       ((s[j+6]=' ')or(s[j+6]='>'))then InStyle:=True
    else if InStyle and (s[j-7]='<')and(s[j-6]='/')and
       ((s[j-5]='s')or(s[j-5]='S'))and
       ((s[j-4]='t')or(s[j-4]='T'))and
       ((s[j-3]='y')or(s[j-3]='Y'))and
       ((s[j-2]='l')or(s[j-2]='L'))and
       ((s[j-1]='e')or(s[j-1]='E'))and
       (s[j]='>')then begin InStyle:=False; Continue; end;
    if InScript or InStyle or InLink then Continue;
    if (s[j]='<') then InTeg:=True
    else if InTeg and (s[j]='>') then InTeg:=False
    else if not InTeg then begin
      Inc(NotInTegC);
      Result[NotInTegC]:=s[j];
    end;
  end;
  SetLength(Result, NotInTegC);
end;

авторы: Elfebet, Fedia, Quadr0 

Автор: Elfebet 17.11.2006, 17:43
частый вопрос: найти все ссылки в html странице
Код

function NormalizeUrl(var Url:String):Boolean;
var i:Integer;
begin
  Result:=False;
  Url:=StringReplace(Url, '#13#10', '', [rfReplaceAll]);
  i:=Pos(' ', Url);
  if (i<>0) then Url:=Copy(Url, 1, i-1);
  Url:=StringReplace(Url, '"', '', [rfReplaceAll]);
  Url:=StringReplace(Url, '''', '', [rfReplaceAll]);
  if ((Pos(';', Url)<>0)or(Pos('mailto:', Url)<>0)or(Pos('file://', Url)<>0)) then Exit;
  if Url='' then Exit;
  Result:=True;
end;

function FindURLs(s:String):TStringList;
var NextFindURL:Boolean;
    idxPos:Integer;
    link:string;
begin
  Result:=TStringList.Create;
  NextFindURL:=true;
  idxPos:=1;
  while NextFindURL do begin
    idxPos:=PosEx('<a ', s, idxPos);
    if idxPos=0 then begin NextFindURL:=False; Continue; end;
    Inc(idxPos, 2);
    idxPos:=PosEx('href=', s, idxPos);
    if idxPos<=0 then Continue;
    Inc(idxPos, 5);
    link:=Copy(s, idxPos, PosEx('>', s, idxPos)-idxPos);
    if NormalizeUrl(link) then Result.Add(link);
  end;
end;

использование
Код

list:=TStringList.Create;
list.LoadFromFile('Ваш файл');
list:=FindURLs(list.Text);
ShowMessage(list.Text);
list.Free;

автор: Elfebet

тоже функция довольно быстрая, один не достаток надо фунции передавать текст с буквами нижного регистра, чтобы он нашел все ссылки, в такой ситуации я использовал функцию fastPosNoCase из FastStrings.pas (http://www.droopyeyes.com/downloads/faststrings.zip)

Автор: Snowy 17.11.2006, 18:16
Конвертировать RTF в HTML: http://forum.vingrad.ru/index.php?showtopic=89499&view=findpost&p=689085
Автор: Snowy
Примечание: код, который сейчас находится в DRKB, не только не рабочий, но и не имеет вообще никакого отношения ни к RTF, ни к HTML.
Но при этом гордо лежит именно под этим заголовком smile
P.S. Мой код отработан, проверен. Единственно, что хотелось бы добавить - подсветка гиперссылок.
Работаю над этим.


TRichEdit. Определить, используется ли в тексте форматирование, или же просто текст.
Код
function IsRichFormated(RE: TRichEdit): boolean;
var
  i: integer;
begin
  result := false;
  Re.SelStart := 0;
  Re.DefAttributes.Assign(Re.SelAttributes);
  for i := 0 to Length(Re.Text) do
  begin
    Re.SelStart := i;
    if (Re.SelAttributes.Name  <> Re.DefAttributes.Name) or
       (Re.SelAttributes.Color <> Re.DefAttributes.Color) or
       (Re.SelAttributes.Size  <> Re.DefAttributes.Size) or
       (fsBold in Re.SelAttributes.Style) or
       (fsItalic in Re.SelAttributes.Style) or
       (fsUnderline in Re.SelAttributes.Style) or
       (fsStrikeOut in Re.SelAttributes.Style) or
       (Re.Paragraph.Numbering <> nsNone) or
       (Re.Paragraph.Alignment <> taLeftJustify) then
     begin
       result := true;
       Break;
     end;
  end;
end;
Авторы: Snowy, Quadr0

Автор: Snowy 20.11.2006, 17:23
Готово. Переделал функцию.

Функция конвертирует RTF и обычный текст в HTML.
Производит детект урлов, выделяет их гиперссылкой.

Код

unit Rtf2Html;

interface

uses Windows, SysUtils, Classes, Graphics, ComCtrls, RichEdit, Forms;

function TextToHtml(s: string): string;
{* Конвертирует plain/text в html }

implementation

function TextToHtml(s: string): string;
const ot = #1'<'; ct = '>'#1;

  function HtmlColor(Col: integer): string;
  begin
    Col := ColorToRGB(Col);
    Result := '#' + Format('%.2x%.2x%.2x', [GetRValue(Col), GetGValue(Col), GetBValue(Col)]);
  end;

  function IsRTF(txt: string): boolean;
  begin
    if copy(txt,1,5) = '{\rtf' then result := true
    else result := false;
  end;

  function HtmlChar(ch: char): string;
  const
    sim: array[1..6] of string = ('&lt;', '&gt;','&quot;','&amp;', '<br>', '');
    sims = '<>"&'#13#10;
  begin
    if pos(ch, sims) > 0 then result := sim[pos(ch, sims)]
    else result := ch;
  end;

  function DetectUrl(txt: string): string;
  var
    i,j: integer;
    s,l: string;
    h:   boolean;
  begin
    result := ''; l := LowerCase(txt); h := false; i := 0;
    repeat
      inc(i);
      if txt[i] = #1 then h := not h;
      if h then result := result + txt[i]
      else
        if (copy(l, i, 7) = 'http://')
        or (copy(l, i, 8) = 'https://')
        or (copy(l, i, 6) = 'ftp://')
        or (copy(l, i, 4) = 'www.') then begin
          s := '';
          for j := i to Length(l) do
            if pos(l[j], #1#13#10' <>') = 0 then s := s + txt[j]
            else Break;
          inc(i, Length(s)-1);
          result := result + ot + 'a href="';
          if pos('://', s) = 0 then result := result + 'http://';
          result := result + s + '"' + ct + s + ot + '/a' + ct;
        end else result := result + txt[i];
    until i >= Length(l);
  end;

  function RtfToHtml(s: string): string;
  var
    re: TRichEdit;
    ss: TStringStream;
    f:  string;
    i, sz, cl: integer;
    st: TFontStyles;
    al: TAlignment;
    n:  TNumberingStyle;
    sp: boolean;
  begin
    result := '';
    re := TRichEdit.Create(nil);
    re.Visible := false; re.Width := 4096; re.Height := 0;
    re.Parent := Application.MainForm;
    ss := TStringStream.Create(s);
    re.Lines.LoadFromStream(ss);
    ss.Free; s := re.Text;
    f := ''; sz := 0; cl := -1; st := []; sp := false;
    al := taLeftJustify; n := nsNone;
    for i := 1 to Length(s) do
    begin
      re.SelStart := i;
      if (re.CaretPos.X=0) and (re.Lines[re.CaretPos.Y]='') then
        if s[i]=#13 then result:=result+ot+'br'+ct;
      if re.CaretPos.X = 1 then begin // Paragraph
        if re.Paragraph.Alignment <> al then begin
          if al <> taLeftJustify then result := result + ot+'/div'+ct;
          al := re.Paragraph.Alignment;
          if al = taRightJustify then result := result + ot+'div align=right'+ct;
          if al = taCenter then result := result + ot+'div align=center'+ct;
        end else if n = nsNone then result := result + ot+'br'+ct;
        if n = nsBullet then result := result+ot+'/li'+ct;
        if (re.Paragraph.Numbering = nsBullet) and (n = nsNone) then
        begin result := result + ot +'ul'+ct; n := nsBullet; end;
        if (re.Paragraph.Numbering <> nsBullet) and (n = nsBullet) then
        begin result := result + ot+'/ul'+ct; n := nsNone; end;
        if n = nsBullet then result := result + ot+'li'+ct;
      end;
      with re.SelAttributes do // Font
        if (f <> Name) or (sz <> Size) or (cl <> Color) or (st <> Style) then
        begin
          if sp then begin result := result + ot+'/span'+ct; sp := false; end;
          if s[i] > #31 then begin
            f := Name; sz := Size; cl := Color; st := Style;
            result := result + ot+'span style="{font-family:' + f + ';font-size:' +
            IntToStr(sz) + 'pt;';
            if cl <> 0 then result := result + 'color:' + HtmlColor(cl)+';';
            if fsBold in st then result := result + 'font-weight:bold;';
            if fsItalic in st then result := result + 'font-style:italic;';
            if fsUnderline in st then result := result + 'text-decoration:underline;';
            if fsStrikeOut in st then result := result + 'text-decoration:line-through;';
            result := result + '}"'+ct; sp := true;
          end;
        end;
      if s[i] > #31 then result := result + s[i];
    end;
    if sp then result := result + ot+'/span'+ct;
    if al <> taLeftJustify then result := result + ot+'/div'+ct;
    if n = nsBullet then result := result + ot+'/ul'+ct;
    re.Free;
  end;

var
  i: integer;
  h: boolean;
begin
  i := 0; result := ''; h := false;
  if IsRTF(s) then s := RtfToHtml(s)
  else result := '<font style="font-size:12pt; font-family:courier">';
  s := DetectUrl(s);
  repeat
    inc(i);
    if s[i] = #1 then h := not h
    else if h then result := result + s[i]
    else result := result + HtmlChar(s[i]);
  until i = Length(s);
end;

end.


Внимание! Функция конвертирует только содержимое.
Если вам нужен полноценный html-файл, нужно дописать заголовок.
Сама функция возвращает только содержимое BODY.

Пример использования:
Код

uses Rtf2Html;

procedure TForm1.Button1Click(Sender: TObject);
var
  sl: TStringList;
  ms: TMemoryStream;
begin
  sl := TStringList.Create;
  try
    //sl.LoadFromFile('1.txt'); // можно грузить rtf или txt
    sl.LoadFromFile('1.rtf');
    sl.Text := TextToHtml(sl.Text);
    //sl.SaveToFile('1.htm'); // можно сохранить результат в файл
    ms := TMemoryStream.Create;
    sl.SaveToStream(ms); ms.Position := 0;
    try // загрузка результата в TWebBrowser. Для краткости ему назначено имя wb
      wb.Navigate('about:blank'); // открываем пустую страницу
      while wb.ReadyState < READYSTATE_INTERACTIVE do
        Application.HandleMessage;
        // загружаем в неё наш html
        (wb.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms));
    finally
      ms.Free;
    end;
  finally
    sl.Free;
  end;
end;
(На форме TWebBrowser и кнопка).

Добавлено @ 17:35 
Код полностью мой до последней буковки.
Код новый, неотработанный.
Вроде работает, но оттестить было бы неплохо.
Прилагаю тестовый проект. Найдёте глюки - пишите.

Автор: Matematik 24.11.2006, 20:11
Вот нашел интересную статью
http://www.dtf.ru/articles/read.php?id=39888
Может будет полезна

Добавлено @ 20:12 
То, что вам никто не говорил о многозадачности в Windows

Автор: Snowy 24.11.2006, 23:26
Цитата(Matematik @  24.11.2006,  20:11 Найти цитируемый пост)
Вот нашел интересную статью
Не думаю, что она имеет отношение к DRKB.
Да, есть несколько интересных практических советов.
Но в целом речь о тонкостях, а не о решениях.
В целом статья наводит на мысль, что человек съел собаку только сейчас и находится в шоке.
Хотя данная информация далеко не засекречена smile
Плюс полезным советам. Естественно я понимаю, что для очень многих эта информация может быть в новость.
В целом 4 за статью.
Но для сборника решений, ИМХО, не подходит.
Почитать полезно, но это не фак.
Полезно почитать тем, кто не сильно представляет реализацию многозадачности Windows, чтобы знать где лежат грабли.
Но далеко не факт, что придётся смотреть, чтоб на них не наступить.
Просто полезная информация. Но не по данной теме.

Автор: Bose 25.11.2006, 20:39
Не знаю, можно лои рекомендовать для DRKB чужие статьи smile 

Наткнулся в интернете на сайт Александра Просторова с довольно интересными статьями о Delphi http://www.softwarer.ru/index.html Я получил массу удовольствия читая их.

Автор: Albinos_x 5.12.2006, 02:25
Цитата(Albinos_x @  9.11.2006,  01:55 Найти цитируемый пост)
Она возможно ещё подвергнется редактированию... но это только тогда, когда появится свободное время, аего в ближайшее время пока не предвидится...  

в документе 18 стр. 

Присоединённый файл ( Кол-во скачиваний: 2 ) 
  _________MS_Excel.zip 24,39 Kb

в статье найдена опечатка, в часности в разделе Организация работы приложения под несколько версий Excel
надо исправить 
Код

if (StrToInt(Copy(ExcelApplication1.Version[lcid],1,pos('.',ExcelApplication1.Version[lcid])-1)))=9 then    
   (ExcelWorkbook1 as Excel2000.ExcelWorkbook).SaveAs(s, EmptyParam, EmptyParam,
                             EmptyParam,  EmptyParam, EmptyParam, EmptyParam, EmptyParam, 
                             EmptyParam,  EmptyParam, EmptyParam,0)    
   else    
   (ExcelWorkbook1 as ExcelXP.ExcelWorkbook).SaveAs(s, EmptyParam, EmptyParam, 
                                      EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, 
                                      EmptyParam, EmptyParam, EmptyParam, EmptyParam,0);    


на 
Код

if (StrToInt(Copy(ExcelApplication1.Version[lcid],1,pos('.',ExcelApplication1.Version[lcid])-1)))=9 then    
   (ExcelWorkbook1 as Excel2000.TExcelWorkbook).SaveAs(s, EmptyParam, EmptyParam,
                             EmptyParam,  EmptyParam, EmptyParam, EmptyParam, EmptyParam, 
                             EmptyParam,  EmptyParam, EmptyParam,0)    
   else    
   (ExcelWorkbook1 as ExcelXP.TExcelWorkbook).SaveAs(s, EmptyParam, EmptyParam, 
                                      EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, 
                                      EmptyParam, EmptyParam, EmptyParam, EmptyParam,0);    



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


на всякий случай прикрепляю исправленную статью...

Автор: Yanis 17.1.2007, 12:06
Однажды понадобилось использовать функцию GetFileAttributes. Было принято решение оформить её результат в виде множества атрибутов. В результате получилась нижеприведённая функция. Ни что не мешает использовать её в оригинальном варианте, но иногда удобнее использовать такой вариант:
Код
TFileAttributes = set of (fatArchive, fatCompressed, fatDirectory, fatHidden, fatNormal,
                          fatOffline, fatReadOnly, fatSystem, fatTemporary);

function GetFileAttributes(const s: string): TFileAttributes;
var
  h: DWORD;
begin
  h := Windows.GetFileAttributes(PChar(s));
  Result := [];
  if h = MAXDWORD then Exit;

  if (h and FILE_ATTRIBUTE_ARCHIVE) = FILE_ATTRIBUTE_ARCHIVE then
    Result := Result + [fatArchive];

  if (h and FILE_ATTRIBUTE_COMPRESSED) = FILE_ATTRIBUTE_COMPRESSED then
    Result := Result + [fatCompressed];

  if (h and FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY then
    Result := Result + [fatDirectory];

  if (h and FILE_ATTRIBUTE_HIDDEN) = FILE_ATTRIBUTE_HIDDEN then
    Result := Result + [fatHidden];

  if (h and FILE_ATTRIBUTE_NORMAL) = FILE_ATTRIBUTE_NORMAL then
    Result := Result + [fatNormal];

  if (h and FILE_ATTRIBUTE_OFFLINE) = FILE_ATTRIBUTE_OFFLINE then
    Result := Result + [fatOffline];

  if (h and FILE_ATTRIBUTE_READONLY) = FILE_ATTRIBUTE_READONLY then
    Result := Result + [fatReadOnly];

  if (h and FILE_ATTRIBUTE_SYSTEM) = FILE_ATTRIBUTE_SYSTEM then
    Result := Result + [fatSystem];

  if (h and FILE_ATTRIBUTE_TEMPORARY) = FILE_ATTRIBUTE_TEMPORARY then
    Result := Result + [fatTemporary];
end;


Использование: 
Код
  if fatDirectory in GetFileAttributes('C:\windows\') then
    ShowMessage('Directory');

Автор: Akella 25.1.2007, 12:16
Проблема с русскими символами (Snowy)
http://forum.vingrad.ru/index.php?showtopic=82093&view=findpost&p=634050

Показ диалога выбора папки (Я)
Добавлено @ 12:17 
и ещё вот это
http://forum.vingrad.ru/index.php?showtopic=41157&view=findpost&p=1010690

Автор: Sunvas 25.1.2007, 22:39
А когда выйдет DRKB 3 ? интересно знать..

Автор: Vit 26.1.2007, 19:16
Цитата(Sunvas @  25.1.2007,  13:39 Найти цитируемый пост)
А когда выйдет DRKB 3 ? интересно знать.. 


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

Автор: Romikgy 26.1.2007, 21:34
Цитата(Vit @  26.1.2007,  18:16 Найти цитируемый пост)
DRKB - дело примерно месяца. 

будет в chm формате ?

Автор: Sunvas 26.1.2007, 21:46
Цитата(Romikgy @  26.1.2007,  21:34 Найти цитируемый пост)
будет в chm формате ?

Очень желательно кстати.

Автор: Vit 28.1.2007, 05:32
Цитата(Romikgy @ 26.1.2007,  12:34)
будет в chm формате ?

да

Автор: Romikgy 28.1.2007, 14:11
Цитата(Vit @  28.1.2007,  04:32 Найти цитируемый пост)
да 

радует и сиба smile

Автор: Yanis 31.1.2007, 10:55
WinAPI аналог известной процедуры ScanDir.
Код
procedure ScanDir(Dir: string; var sFiles: string);
var
  fnd: TWin32FindData;
  hFnd: DWORD;
begin
  if Dir <> '' then
    if Dir[length(Dir)] <> '\' then Dir := Dir + '\';

  hFnd := FindFirstFile(PChar(Dir + '*.*'), fnd);
  if hFnd <> INVALID_HANDLE_VALUE then
    repeat
      if (fnd.cFileName[0] = '.') or (AnsiString(fnd.cFileName) = '..') then
        Continue;

      if Boolean((fnd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)) then
        ScanDir(Dir + fnd.cFileName, sFiles)
      else
        sFiles := sFiles + fnd.cFileName + #13#10;

    until not FindNextFile(hFnd, fnd);

  sFiles := Copy(sFiles, 1, Length(sFiles) - 2);
  Windows.FindClose(hFnd);
end;


http://forum.vingrad.ru/index.php?showtopic=132394&view=findpost&p=1001949

Автор: Akella 5.2.2007, 09:48
Так можно экспортировать данные из DBGridEh в разные форматы.


Код

uses ..., DBGridEhImpExp, ...

procedure TfmMain.SaveSelectionAs(Grid:TDBGridEh);
var ExpClass:TDBGridEhExportClass;
    Ext:String;
    SaveDialog1:TSaveDialog;
begin
  if not canExportData(True) then exit;

  begin
    SaveDialog1 := TSaveDialog.Create(self);
    SaveDialog1.Filter := 'Текстовый файл(*.txt)|*.txt|Файл с разделителями(*.csv)|*.csv|Веб-страница(*.htm)|*.htm|Rich Text Format(*.rtf)|*.rtf|MS Excel(*.xls)|*.xls';
    SaveDialog1.FileName := 'Export';

    if SaveDialog1.Execute then
    begin

      case SaveDialog1.FilterIndex of
        1: begin ExpClass := TDBGridEhExportAsText; Ext := 'txt'; end;
        2: begin ExpClass := TDBGridEhExportAsCSV; Ext := 'csv'; end;
        3: begin ExpClass := TDBGridEhExportAsHTML; Ext := 'htm'; end;
        4: begin ExpClass := TDBGridEhExportAsRTF; Ext := 'rtf'; end;
        5: begin ExpClass := TDBGridEhExportAsXLS; Ext := 'xls'; end;
      else
        ExpClass := nil; Ext := '';
      end;
      if ExpClass <> nil then  begin
        if UpperCase(Copy(SaveDialog1.FileName,Length(SaveDialog1.FileName)-2,3)) <> UpperCase(Ext) then
          SaveDialog1.FileName := SaveDialog1.FileName + '.' + Ext;
        SaveDBGridEhToExportFile(ExpClass,Grid, SaveDialog1.FileName,True);
      end;//if ExpClass <> nil then  begin
    end;

    FreeAndNil(SaveDialog1);
  end;
end;



procedure TfmMain.SaveDBGridEhToExportFile(ExportClass: TDBGridEhExportClass;
  DBGridEh: TCustomDBGridEh; const FileName: String; IsSaveAll: Boolean);
var DBGridEhExport: TDBGridEhExport;
begin
  DBGridEhExport := ExportClass.Create;
  try
    DBGridEhExport.DBGridEh := DBGridEh;
    DBGridEhExport.ExportToFile(FileName, IsSaveAll);
  finally
    DBGridEhExport.Free;
  end;
end;


//использование
if (ActiveControl is TDBGridEh) then
  SaveSelectionAs(ActiveControl as TDBGridEh);

Powered by Invision Power Board (http://www.invisionboard.com)
© Invision Power Services (http://www.invisionpower.com)