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

Rouse_

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

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

Загрузка ...

Опытный

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

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

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

M
Snowy

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

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

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

Girder

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

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

Загрузка ...

Лентяй 2

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

Репутация: 31
Всего: 155

Модератор: Сообщение скрыто.

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

Как слышим, так и пишим.
Истина где-то там...

Snowy

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

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

Загрузка ...

Эксперт

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

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

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

Rouse_

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

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

Загрузка ...

Опытный

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

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

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

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

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

Snowy

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

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

Загрузка ...

Эксперт

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

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

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

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

Akella

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

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

Загрузка ...

Творец

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

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

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

Rouse_

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

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

Загрузка ...

Опытный

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

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

Akella, ну так сюда и кидай smile

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

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

Yanis

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

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

Загрузка ...

Эксперт

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

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

Цитата(Rouse_ @ 27.9.2006, 23:34

)

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

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

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

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

*щёлк*

Akella

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

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

Загрузка ...

Творец

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

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

Я когда-то для 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;

Это сообщение отредактировал(а) Akella - 5.2.2007, 09:26

Vit

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

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

Загрузка ...

Vitaly Nevzorov

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

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

Цитата(Rouse_ @ 27.9.2006, 13:34

)

Я хотел раньше... хотя может Rouse_ и более приземлён smile

. Тем более что появилось время заниматься этим в рабочее время.
Ладно, работаем, а потом посмотрим...

Цитата(Yanis @ 28.9.2006, 01:15

)

А что будем делать с наработками из Арсенал форумистов? Просто тупа перекидывать линки на посты оттуда сюда?

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

И ещё:

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

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

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

Yanis

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

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

Загрузка ...

Эксперт

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

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

Цитата(Vit @ 28.9.2006, 15:33

)

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

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

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

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

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

Это сообщение отредактировал(а) Yanis - 28.9.2006, 16:40

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

*щёлк*

Yanis

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

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

Загрузка ...

Эксперт

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

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

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

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

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

*щёлк*

Yanis

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

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

Загрузка ...

Эксперт

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

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

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

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

*щёлк*

Vit

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

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

Загрузка ...

Vitaly Nevzorov

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

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

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

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

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

Elfebet

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

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

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 545
Регистрация: 15.5.2006
Где: Украина. Запорожь е.

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

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 (ссылка)

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

Загрузка ...

Опытный

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

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

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

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

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

Цитата

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

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

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

Vit

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

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

Загрузка ...

Vitaly Nevzorov

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

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

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

)

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

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

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

Snowy

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

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

Загрузка ...

Эксперт

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

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

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

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

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

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

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

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

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

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

Alexeis

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

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

Загрузка ...

Амеба

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

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

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

)

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

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

Код


 var
  h : THandle;

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

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

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

Код


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

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

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

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

Код


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

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

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

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

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

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

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

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

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

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

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

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

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

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

Alexeis

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

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

Загрузка ...

Амеба

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

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

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

Код


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

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

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

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

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

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

Код


var
  ComObj;

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

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

Akella

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

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

Загрузка ...

Творец

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

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

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

)

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

Yanis

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

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

Загрузка ...

Эксперт

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

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

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

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

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

*щёлк*

Rouse_

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

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

Загрузка ...

Опытный

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

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

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

)

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

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

Код


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

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

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

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

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

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

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

Snowy

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

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

Загрузка ...

Эксперт

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

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

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

Rouse_

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

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

Загрузка ...

Опытный

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

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

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

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

Код


function GetDrivesData(const NotNT: Boolean): String;

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

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

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

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

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

Albinos_x

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

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

Загрузка ...

Evil Skynet

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

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

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

)

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

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

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

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

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

Albinos_x

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

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

Загрузка ...

Evil Skynet

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

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

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

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

Код

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

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

Код

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

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

Код

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

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

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

функция:

Код


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

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

Код


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

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

Код


 ComboBox1.AutoComplete:=false;

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

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

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

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

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

Albinos_x

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

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

Загрузка ...

Evil Skynet

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

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

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

Код


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

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

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

Код


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

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

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

Quadr0

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

(голосов: 0)

Загрузка ...

Unregistered

...

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

Albinos_x

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

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

Загрузка ...

Evil Skynet

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

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

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

Код


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Voyager

Дата 2.10.2006, 07:02 (ссылка)

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

Загрузка ...

Опытный

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

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

Вот моя функция получения пути до программы из файла ярлыка:

Код


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 (ссылка)

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

Загрузка ...

Соль и сахар

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

Репутация: 28
Всего: 89

Вот мое решение как нарисовать эффект "Муравьи" на форме.
http://forum.vingrad.ru/index.php?showtopi...st&p=693628

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

Воспитывая детей по своему образу и подобию, родители почему-то надеются, что они будут лучше их.

FF90h

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

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

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 72
Регистрация: 1.7.2006
Где: Планета Земля

Репутация: нет
Всего: 1

Смена МАК адреса тестировал на 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;
...

Это сообщение отредактировал(а) FF90h - 8.10.2006, 13:46

Sunvas

Дата 9.10.2006, 20:57 (ссылка)

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

Загрузка ...

Соль и сахар

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

Репутация: 28
Всего: 89

Элементы комбинаторики - размещения, перестановки, сочетания

Вот три функции для вычисления всех возможных вариантов выбора элементов методом сочетания, перестановки и размещения. Где 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;

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

Это сообщение отредактировал(а) Sunvas - 7.1.2007, 21:13

Присоединённый файл ( Кол-во скачиваний: 16 )

kombinatorika.zip 2,36 Kb

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

Воспитывая детей по своему образу и подобию, родители почему-то надеются, что они будут лучше их.

Yanis

Дата 13.10.2006, 10:09 (ссылка)

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

Загрузка ...

Эксперт

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

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

Добавление иконки в стандартный 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?showtopi...st&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?showtopi...st&p=887225

Это сообщение отредактировал(а) Yanis - 13.10.2006, 10:17

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

*щёлк*

Akella

Дата 19.10.2006, 13:21 (ссылка)

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

Загрузка ...

Творец

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

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

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 (ссылка)

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

Загрузка ...

Эксперт

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

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

Akella, а какое отношение C# имеет к DRKB?

Akella

Дата 19.10.2006, 15:29 (ссылка)

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

Загрузка ...

Творец

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

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

Отлавливаем нажатие клавишь в 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?showtopi...st&p=876524

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

Добавлено @ 15:37

Цитата

Akella, а какое отношение C# имеет к DRKB?

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

Это сообщение отредактировал(а) Akella - 19.10.2006, 15:38

Akella

Дата 23.10.2006, 10:56 (ссылка)

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

Загрузка ...

Творец

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

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

Работа с колонтитулами в 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 (ссылка)

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

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

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

Цитата(Akella @ 19.10.2006, 14:29

)

имхо здесь немного с избыточностью, т.к. в онкейдауне в кее виртуальная кнопка, а она и для больших и для маленьких и вообще для всех раскладок одинакова, вот файлик с инклюдом всех виртуальных кодов ,
использование
добавляем такую вещь
{$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

Присоединённый файл ( Кол-во скачиваний: 18 )

virtual_key.inc 3,03 Kb

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

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

Akella

Дата 23.10.2006, 11:07 (ссылка)

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

Загрузка ...

Творец

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

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

Нраницы и перенос по словам в Excel
http://forum.vingrad.ru/topic-117776.html

TopSergey

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

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

Загрузка ...

Новичок

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

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

Я слыхал тут отбор тем для нового 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 (ссылка)

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

Загрузка ...

Эксперт

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

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

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

Snowy

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

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

Загрузка ...

Эксперт

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

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

Не знаю, стоит ли одна строчка места в 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 (ссылка)

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

Загрузка ...

Творец

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

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

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

Код


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

Addmin

Дата 30.10.2006, 17:40 (ссылка)

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

Загрузка ...

Опытный

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

Репутация: нет
Всего: 15

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

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

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

SimpleFit.ru - блог о том, как заниматься спортом нормальным людям
--
Стимул работы в Сибири - комары.

Vit

Дата 30.10.2006, 19:11 (ссылка)

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

Загрузка ...

Vitaly Nevzorov

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

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

Цитата(Addmin @ 30.10.2006, 08:40

)

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

Да

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

Addmin

Дата 31.10.2006, 11:12 (ссылка)

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

Загрузка ...

Опытный

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

Репутация: нет
Всего: 15

Ммм... Нашёл сообщение об 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 - прилагаются.

Присоединённый файл ( Кол-во скачиваний: 24 )

pe_optimizer.zip 69,23 Kb

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

SimpleFit.ru - блог о том, как заниматься спортом нормальным людям
--
Стимул работы в Сибири - комары.

Snowy

Дата 2.11.2006, 02:24 (ссылка)

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

Загрузка ...

Эксперт

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

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

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

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

Addmin

Дата 4.11.2006, 05:42 (ссылка)

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

Загрузка ...

Опытный

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

Репутация: нет
Всего: 15

А какой формат статьи требуется для DRKB Explorer? Простые HTML или ещё что?

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

SimpleFit.ru - блог о том, как заниматься спортом нормальным людям
--
Стимул работы в Сибири - комары.

Quadr0

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

(голосов: 0)

Загрузка ...

Unregistered

...

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

Vit

Дата 6.11.2006, 16:19 (ссылка)

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

Загрузка ...

Vitaly Nevzorov

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

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

Цитата(Addmin @ 3.11.2006, 20:42

)

А какой формат статьи требуется для DRKB Explorer? Простые HTML или ещё что?

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

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

Insert

Дата 6.11.2006, 21:01 (ссылка)

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

Загрузка ...

Бывалый

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

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

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

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

пьяный русский кодер практически непобедим

Quadr0

Дата 6.11.2006, 21:41 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

...

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

Insert

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

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

Загрузка ...

Бывалый

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

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

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

Это сообщение отредактировал(а) Insert - 6.11.2006, 23:09

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

пьяный русский кодер практически непобедим

Vit

Дата 7.11.2006, 15:28 (ссылка)

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

Загрузка ...

Vitaly Nevzorov

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

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

Цитата(Insert @ 6.11.2006, 12:01

)

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

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

Akella

Дата 8.11.2006, 10:05 (ссылка)

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

Загрузка ...

Творец

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

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

Цитата(Insert @ 6.11.2006, 21:01

)

Только не в PDF. smile

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

Albinos_x

Дата 8.11.2006, 17:16 (ссылка)

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

Загрузка ...

Evil Skynet

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

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

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

Это сообщение отредактировал(а) Albinos_x - 8.11.2006, 17:23

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

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

Vit

Дата 8.11.2006, 18:12 (ссылка)

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

Загрузка ...

Vitaly Nevzorov

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

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

Цитата(Albinos_x @ 8.11.2006, 08:16

)

в формате Word подойдёт?

Да

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

Albinos_x

Дата 8.11.2006, 20:27 (ссылка)

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

Загрузка ...

Evil Skynet

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

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

прикрепляю файл...

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

Присоединённый файл ( Кол-во скачиваний: 16 )

_________MS_Word.zip 35,73 Kb

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

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

Albinos_x

Дата 9.11.2006, 01:55 (ссылка)

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

Загрузка ...

Evil Skynet

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

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

Прикрепляю отредактированную статью по компаненте ExcelApplication ...

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

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

Присоединённый файл ( Кол-во скачиваний: 5 )

_________MS_Excel.zip 24,39 Kb

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

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

tripsin

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

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

Загрузка ...

Новичок

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

Репутация: нет
Всего: 3

Посмотрите. Может что-то мое сгодится.

Rodman

Дата 14.11.2006, 22:05 (ссылка)

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

Загрузка ...

CIO

Профиль
Группа: Участник
Сообщений: 6144
Регистрация: 7.5.2006
Где: Ukraine ⇛ Kyiv ci ty

Репутация: 7
Всего: 122

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

Но единственное примечание - требуется компонент из JEDI (или подобный)...

Присоединённый файл ( Кол-во скачиваний: 2 )

XMLvsDBGrid.rar 6,20 Kb

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

CRM с функцией АвтоОбзвона

Лотереи мира

Rodman

Дата 15.11.2006, 17:33 (ссылка)

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

Загрузка ...

CIO

Профиль
Группа: Участник
Сообщений: 6144
Регистрация: 7.5.2006
Где: Ukraine ⇛ Kyiv ci ty

Репутация: 7
Всего: 122

И вот еще коварный вопрос по базам. С рудом нашел. В старой версии 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);

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

CRM с функцией АвтоОбзвона

Лотереи мира

Vit

Дата 15.11.2006, 18:52 (ссылка)

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

Загрузка ...

Vitaly Nevzorov

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

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

Цитата(Rodman @ 15.11.2006, 08:33

)

вот еще коварный вопрос по базам. С рудом нашел. В старой версии DRKB такого нет...

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

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

Alex

Дата 15.11.2006, 21:34 (ссылка)

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

Загрузка ...

Эксперт

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

Репутация: 80
Всего: 162

Цитата(Akella @ 27.10.2006, 09:04)

Код


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

только не нужно это в таком виде включать в DRKB smile

Точнее код правильный, но описание к нему должно быть другим. Это код будет работать во все Delphi начиная с BDS2006 и в случаи утечек просто будет сообщения, что они есть без указания конкретных модулей. Для получения информации в каком модуле происходит утечка можно воспользоваться бесплатной библиотекой FastMM

Добавлено @ 21:43
Строковые типы в Delphi. Особенности реализации и использования.

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

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

Написать можно все - главное четко представлять, что ты хочешь получить в конце.

Snowy

Дата 16.11.2006, 02:15 (ссылка)

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

Загрузка ...

Эксперт

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

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

M
Snowy

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

Elfebet

Дата 17.11.2006, 17:11 (ссылка)

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

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 545
Регистрация: 15.5.2006
Где: Украина. Запорожь е.

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

Удаление 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 (ссылка)

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

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 545
Регистрация: 15.5.2006
Где: Украина. Запорожь е.

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

частый вопрос: найти все ссылки в 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)

Это сообщение отредактировал(а) Elfebet - 20.11.2006, 12:02

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

Программист не должен всё знать... он должен знать где можно посмотреть

Snowy

Дата 17.11.2006, 18:16 (ссылка)

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

Загрузка ...

Эксперт

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

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

Конвертировать RTF в HTML: http://forum.vingrad.ru/index.php?showtopi...st&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 (ссылка)

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

Загрузка ...

Эксперт

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

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

Готово. Переделал функцию.

Функция конвертирует 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
Код полностью мой до последней буковки.
Код новый, неотработанный.
Вроде работает, но оттестить было бы неплохо.
Прилагаю тестовый проект. Найдёте глюки - пишите.

Присоединённый файл ( Кол-во скачиваний: 17 )

RtfToHtml.zip 19,58 Kb

Matematik

Дата 24.11.2006, 20:11 (ссылка)

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

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1027
Регистрация: 11.3.2006

Репутация: 17
Всего: 50

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

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

Snowy

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

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

Загрузка ...

Эксперт

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

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

Цитата(Matematik @ 24.11.2006, 20:11

)

Вот нашел интересную статью

Не думаю, что она имеет отношение к DRKB.
Да, есть несколько интересных практических советов.
Но в целом речь о тонкостях, а не о решениях.
В целом статья наводит на мысль, что человек съел собаку только сейчас и находится в шоке.
Хотя данная информация далеко не засекречена smile

Плюс полезным советам. Естественно я понимаю, что для очень многих эта информация может быть в новость.
В целом 4 за статью.
Но для сборника решений, ИМХО, не подходит.
Почитать полезно, но это не фак.
Полезно почитать тем, кто не сильно представляет реализацию многозадачности Windows, чтобы знать где лежат грабли.
Но далеко не факт, что придётся смотреть, чтоб на них не наступить.
Просто полезная информация. Но не по данной теме.

Bose

Дата 25.11.2006, 20:39 (ссылка)

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

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 1458
Регистрация: 5.3.2005
Где: Riga, Latvia

Репутация: 23
Всего: 51

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

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

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

Лучшее о Delphi за 2013 год. Подборка ссылок.

Albinos_x

Дата 5.12.2006, 02:25 (ссылка)

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

Загрузка ...

Evil Skynet

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

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

Цитата(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);

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

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

Присоединённый файл ( Кол-во скачиваний: 5 )

_________MS_Excel.zip 24,86 Kb

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

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

Yanis

Дата 17.1.2007, 12:06 (ссылка)

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

Загрузка ...

Эксперт

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

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

Однажды понадобилось использовать функцию 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 (ссылка)

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

Загрузка ...

Творец

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

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

Проблема с русскими символами (Snowy)
http://forum.vingrad.ru/index.php?showtopi...st&p=634050

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

Это сообщение отредактировал(а) Akella - 25.1.2007, 12:18

Sunvas

Дата 25.1.2007, 22:39 (ссылка)

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

Загрузка ...

Соль и сахар

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

Репутация: 28
Всего: 89

А когда выйдет DRKB 3 ? интересно знать..

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

Воспитывая детей по своему образу и подобию, родители почему-то надеются, что они будут лучше их.

Vit

Дата 26.1.2007, 19:16 (ссылка)

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

Загрузка ...

Vitaly Nevzorov

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

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

Цитата(Sunvas @ 25.1.2007, 13:39

)

А когда выйдет DRKB 3 ? интересно знать..

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

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

Romikgy

Дата 26.1.2007, 21:34 (ссылка)

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

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

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

Цитата(Vit @ 26.1.2007, 18:16

)

DRKB - дело примерно месяца.

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

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

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

Sunvas

Дата 26.1.2007, 21:46 (ссылка)

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

Загрузка ...

Соль и сахар

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

Репутация: 28
Всего: 89

Цитата(Romikgy @ 26.1.2007, 21:34

)

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

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

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

Воспитывая детей по своему образу и подобию, родители почему-то надеются, что они будут лучше их.

Vit

Дата 28.1.2007, 05:32 (ссылка)

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

Загрузка ...

Vitaly Nevzorov

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

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

Цитата(Romikgy @ 26.1.2007, 12:34)

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

да

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

Romikgy

Дата 28.1.2007, 14:11 (ссылка)

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

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

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

Цитата(Vit @ 28.1.2007, 04:32

)

да

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

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

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

Yanis

Дата 31.1.2007, 10:55 (ссылка)

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

Загрузка ...

Эксперт

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

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

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;

ссылка

Это сообщение отредактировал(а) Yanis - 31.1.2007, 10:55

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

*щёлк*

Akella

Дата 5.2.2007, 09:48 (ссылка)

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

Загрузка ...

Творец

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

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

Так можно экспортировать данные из 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);

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