Версия для печати темы Нажмите сюда для просмотра этой темы в оригинальном формате

Форум программистов > Delphi: Общие вопросы > Пришло время создавать новую версию DRKB

Автор: Vit 17.11.2004, 16:16

Нужна помощь в поиске тем по форуму за последние пол года достойных включения в DRKB

Автор: Гавинда 17.11.2004, 20:02

Привет Vit. Хорошая идея. Я смог бы помочь в меру своих способностей. Можешь выслать конкретные предложения на e-mail.

Автор: MacTep 17.11.2004, 23:50

Я могу помочь! Что от меня требуется?

Автор: Alex 18.11.2004, 00:42

Гавинда и MacTep вимательно прочитайте Цитата(Vit @ 17.11.2004, 16:16) Нужна помощь в поиске тем по форуму за последние пол года достойных включения в DRKB

Автор: MacTep 18.11.2004, 06:31

Alex, Я на это согласен. Приступать к поиску? Просто сообщать вам о достойных темах для DRKB по моему мнению? Я правильно понял?

Автор: Vit 18.11.2004, 14:30

Цитата(MacTep @ 17.11.2004, 21:31) Просто сообщать вам о достойных темах для DRKB по моему мнению? Я правильно понял? Не совсем, главное ещё убедится, что в DRKB их нет.

Автор: MacTep 18.11.2004, 16:45

Цитата Не совсем, главное ещё убедится, что в DRKB их нет. ну так это и так понятно! Все понял! Буду работать, надеюсь, смогу помочь форуму хоть чем-то!

Автор: Vit 18.11.2004, 16:55

Цитата(MacTep @ 18.11.2004, 07:45) ну так это и так понятно! Это как раз и есть самое сложное в этой работе. Когда ожидать результатов и какие разделы ты будешь просматривать? Кстати линки на темы можно бросать прямо сюда.

Автор: MacTep 18.11.2004, 18:07

Цитата Кстати линки на темы можно бросать прямо сюда Понял! Буду смотреть темы: Общие вопросы и Базы данных и репортинг! Нормально?

Автор: MacTep 18.11.2004, 21:04

И еще Паскаль.

Автор: MacTep 18.11.2004, 21:19

Посмотрел раздел Паскаль. Нашел несколько интересных вещей: http://forum.vingrad.ru/index.php?showtopic=32813 - решение буквенного ребуса; http://forum.vingrad.ru/index.php?showtopic=32433 - перевод десятичных чисел в двоичные; http://forum.vingrad.ru/index.php?showtopic=34453 - exeшник в Паскале; http://forum.vingrad.ru/index.php?showtopic=34479 - решение квадратного уравнения в Паскале Думаю сойдет для DRKB. Есть предложение сделать в DRKB раздел Паскаль. Или ты не хочешь? Как думаешь? Я думаю, что популярность DRKB от этого только возрастет, так как молодая аудитория к нему еще подтянется!

Автор: Alex 18.11.2004, 21:54

http://forum.vingrad.ru/index.php?showtopic=17986 -Как сделать окно произвольной формы?

Автор: Vit 18.11.2004, 22:24

Цитата(MacTep @ 18.11.2004, 12:19) http://forum.vingrad.ru/index.php?showtopic=32433 - перевод десятичных чисел в двоичные; Разве этого нет в DRKB? Спасибо... Всё будет включено. Жду ещё.

Автор: MacTep 18.11.2004, 22:39

Базы данных: http://forum.vingrad.ru/index.php?showtopic=34491 - null-значения в полях базы данных (работа с датой и временем); http://forum.vingrad.ru/index.php?showtopic=34124 - scroll в DBGrid; Вроде этого в DRKB нет. Еще есть ошибка в DRKB. Тема такая: Как создать таблицу в MS Access при помощи DAO? Не DAO, а ADO. Добавлено @ 22:44 Цитата Разве этого нет в DRKB? Sorry, проглядел. Впредь буду внимательнее! Добавлено @ 22:46 http://forum.vingrad.ru/index.php?showtopic=32915 - вопрос слабенький - сортировка по двум условиям, но, думаю, пригодится!

Автор: MacTep 18.11.2004, 23:13

Общие вопросы: http://forum.vingrad.ru/index.php?showtopic=34011 - хинт в любом месте! Добавлено @ 23:18 Паскаль: http://forum.vingrad.ru/index.php?showtopic=34052 - скрытие курсора в текстовом режиме!

Автор: MacTep 18.11.2004, 23:27

http://forum.vingrad.ru/index.php?showtopic=31208 - конечно, математика, но все равно не помешает. Для математики, думаю, нужен дополнительный подраздел. Добавлено @ 23:28 http://forum.vingrad.ru/index.php?showtopic=34663 - директория Windows в Паскале Добавлено @ 23:31 Все тот же Паскаль: http://forum.vingrad.ru/index.php?showtopic=34675 - кубический корень! Vit, так ты будешь создавать раздел в DRKB под Паскаль?

Автор: Vit 19.11.2004, 00:21

Цитата(MacTep @ 18.11.2004, 13:39) Еще есть ошибка в DRKB. Тема такая: Как создать таблицу в MS Access при помощи DAO? Не DAO, а ADO. Базы данных->конкретные базы-> MS Access? Там всё правильно, там через DAO идёт создание... Добавлено @ 00:23 Цитата(MacTep @ 18.11.2004, 14:27) конечно, математика, но все равно не помешает Есть алгоритмы Цитата(MacTep @ 18.11.2004, 14:27) Vit, так ты будешь создавать раздел в DRKB под Паскаль? Не уверен, зависит от того сколько вопросов наберётся... Пока всё можно рассовать в алгоритмы и в язык программирования Дельфи

Автор: Cheba 19.11.2004, 03:46

А можно из других ресурсов?

Автор: December 19.11.2004, 07:59

Я бы хотел упорядочить и структурировать раздел про IE и TWebBrowser. Vit, как это можно осуществить - написать инструкцию, чё куда переместить и где добавить или ты доверишь исходник?

Автор: Vit 19.11.2004, 15:00

Цитата(Cheba @ 18.11.2004, 18:46) А можно из других ресурсов? Нужно Только чтобы ссылки на оригинал были Цитата(December @ 18.11.2004, 22:59) Я бы хотел упорядочить и структурировать раздел про IE и TWebBrowser. Vit, как это можно осуществить - написать инструкцию, чё куда переместить и где добавить или ты доверишь исходник? Да я наверное и сам могу рассортировать если дашь структуру... Опубликуй какую структуры ты предлагаешь а там посмотрим. Исходник я бы доверил, но я сейчас с ним интенсивно работаю, на момент когда ты с ним хоть что-то сделаешь у меня будет уже совсем другой документ, я то его сейчас интенсивно правлю и дополняю

Автор: Alex 19.11.2004, 15:48

Код { **** UBPFD *********** by delphibase.endimus.com **** >> Замена штатного Application.ProcessMessages Хорошо использовать в DLL или бесформенных приложениях, если внутри цикла возникает необходимость в использовании Application.ProcessMessages. Зависимости: Windows, Messages Автор:       ssk, [email protected], ICQ:166758074, Харьков Copyright:   составлено из кусков кода Borland Дата:        7 сентября 2004 г. ***************************************************** } procedure ProcessMessagesEx;   function IsKeyMsg(var Msg: TMsg): Boolean;   const     CN_BASE = $BC00;   var     Wnd: HWND;   begin     Result := False;     with Msg do       if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) then         begin           Wnd := GetCapture;           if Wnd = 0 then             begin               Wnd := HWnd;               if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then                 Result := True;             end               else                 if (LongWord(GetWindowLong(Wnd, GWL_HINSTANCE)) = HInstance) then                   if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then                     Result := True;         end;   end;   function ProcessMessage(var Msg: TMsg): Boolean;   begin     Result := False;     if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then       begin         Result := True;         if Msg.Message <> WM_QUIT then           if not IsKeyMsg(Msg) then             begin               TranslateMessage(Msg);               DispatchMessage(Msg);             end;       end;   end; var  Msg: TMsg; begin  while ProcessMessage(Msg) do {loop}; end;

Автор: Alex 20.11.2004, 18:06

http://forum.vingrad.ru/index.php?act=ST&f=84&t=35153&st=0 - Календарь TDataTimePicker, Как открыть встроенный календарь?

Автор: RA 22.11.2004, 12:23

Вот функции для изменения и получения чуствительности мышки: вопрос конечно не популярный, но пару раз я его слышал. Код Function SetMouseSpeed ( NewSpeed : Integer ) : Boolean; begin  Result := SystemParametersInfo(SPI_SETMOUSESPEED, 1, Pointer(NewSpeed), SPIF_SENDCHANGE ); End; Function GetMouseSpeed : Integer; Var  Int : Integer; begin  SystemParametersInfo(SPI_GETMOUSESPEED, 0, @Int, SPIF_SENDCHANGE );  Result := Int; End;

Автор: Cheba 22.11.2004, 21:13

Системные функции и WinAPI -> Шрифты, языки, кодировки, регионарные стандарты Статьи Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных? и Сохранение параметров шрифта в INI-файле, наверное, нужно объеденить.

Автор: Alex 25.11.2004, 00:42

Как сворачивать все приложение при сворачивании неглавного окна? Код private Procedure WMSysCommand(var message: TWMSysCommand); message WM_SysCommand; ... procedure Form2.WMSysCommand(var message: TWMSysCommand); begin  If message.CmdType = SC_MINIMIZE then    Application.Minimize  else    Inherited; End; Теперь при сворачивании формы сворачиваеться все приложение.

Автор: p0s0l 25.11.2004, 01:36

Как сделать плавное закрытие окна ? Работает в 2k/XP: Код procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin  AnimateWindow(Handle, 500, AW_HIDE or AW_BLEND); end; DelphiPool Добавлено @ 01:36 Как назначить событие на увеличение/уменьшение TSpinEdit с помощью стрелочек ? У TSpinEdit.Button есть дополнительные события, которые не показаны в инспекторе объектов, например, OnUpClick и OnDownClick... Код unit Unit1; interface uses  Windows, Messages, SysUtils, Classes, Graphics,  Controls, Forms, Dialogs, StdCtrls, Spin; type  TForm1 = class(TForm)    SpinEdit1: TSpinEdit;    procedure FormCreate(Sender: TObject);  public    procedure OnButtonUpClick(Sender: TObject); end; var  Form1: TForm1; implementation  {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin  SpinEdit1.Button.OnUpClick := OnButtonUpClick; end; procedure TForm1.OnButtonUpClick(Sender: TObject); begin  MessageDlg('Up Button was clicked.', mtInformation,    [mbOk], 0); end; end. Delphicorner.f9.co.uk Добавлено @ 01:36 Как установить фокус на документе в TWebBrowser ? WebBrowser1.SetFocus ставит фокус на компонент TWebBrowser, а это не всегда то, что нужно. Если нужно поставить фокус на документ в TWebBrowser'е (чтобы, например, кнопки вверх/вниз скроллировали документ, а не ставили фокус на другой компонент), то можно использовать этот код: Код uses ActiveX; with WebBrowser1 do  if Document <> nil then    with Application as IOleobject do      DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle,        GetClientRect); Delphi3000 Добавлено @ 01:39 Как определить, работает ли программа в виртуальной машине ? Для VMWare: Код //////////////////////////////////////////////////////////////////////////////// // //  Simple VMware check on i386 // //    Note: There are plenty ways to detect VMware. This short version bases //    on the fact that VMware intercepts IN instructions to port 0x5658 with //    an magic value of 0x564D5868 in EAX. However, this is *NOT* officially //    documented (used by VMware tools to communicate with the host via VM). // //    Because this might change in future versions - you should look out for //    additional checks (e.g. hardware device IDs, BIOS informations, etc.). //    Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS //    Helper unit to dump the ROM-BIOS (http://www.bendlins.de/nico/delphi). // function IsVMwarePresent(): LongBool; stdcall;  // platform; begin  Result := False; {$IFDEF CPU386}  try    asm            mov     eax, 564D5868h            mov     ebx, 00000000h            mov     ecx, 0000000Ah            mov     edx, 00005658h            in      eax, dx            cmp     ebx, 564D5868h            jne     @@exit            mov     Result, True    @@exit:    end;  except    Result := False;  end; {$ENDIF} end; Для Connectrix's Virtual PC: Код {  This function can be used to determine whether your program is  running from within Connectrix's Virtual PC } function running_inside_vpc: boolean; assembler; asm  push ebp  mov  ecx, offset @@exception_handler  mov  ebp, esp  push ebx  push ecx  push dword ptr fs:[0]  mov  dword ptr fs:[0], esp  mov  ebx, 0 // flag  mov  eax, 1 // VPC function number  // call VPC  db 00Fh, 03Fh, 007h, 00Bh  mov eax, dword ptr ss:[esp]  mov dword ptr fs:[0], eax  add esp, 8  test ebx, ebx  setz al  lea esp, dword ptr ss:[ebp-4]  mov ebx, dword ptr ss:[esp]  mov ebp, dword ptr ss:[esp+4]  add esp, 8  jmp @@ret  @@exception_handler:  mov ecx, [esp+0Ch]  mov dword ptr [ecx+0A4h], -1 // EBX = -1 -> not running, ebx = 0 -> running  add dword ptr [ecx+0B8h], 4 // -> skip past the detection code  xor eax, eax // exception is handled  ret  @@ret: end; SwissDelphiCenter Добавлено @ 01:40 Трассировка пути до определенного IP адреса (как tracert.exe в Windows) Пример использования модуля: Код procedure TForm1.Button1Click(Sender: TObject); var RT : TTraceRoute; begin  RT := TTraceRoute.Create;  RT.Trace('192.168.5.12', ListBox1.Items);  RT.Free; end; В ListBox1 выведется путь в таком формате: IP;TIME;TTL;STATUS Сам модуль: Код unit TraceRt; interface // =========================================================================== // TRACEROUTE Class // Mike Heydon Dec 2003 // // Method // Trace(IpAddress : string; ResultList : TStrings) //             Returns semi-colon delimited list of ip routes to target //             format .. IP ADDRESS; PING TIME MS; TIME TO LIVE; STATUS // // Properties //             IcmpTimeOut : integer (Default = 5000ms) //             IcmpMaxHops : integer (Default = 40) // =========================================================================== uses Forms, Windows, Classes, SysUtils, IdIcmpClient; type     TTraceRoute = class(TObject)     protected       procedure ProcessResponse(Status : TReplyStatus);       procedure AddRoute(AResponseTime : DWORD;                          AStatus: TReplyStatus; const AInfo: string );     private       FIcmpTimeOut,       FIcmpMaxHops : integer;       FResults : TStringList;       FICMP : TIdIcmpClient;       FPingStart : cardinal;       FCurrentTTL : integer;       procedure PingTarget;     public       constructor Create;       procedure Trace(const AIpAddress : string; AResultList : TStrings);       property IcmpTimeOut : integer read FIcmpTimeOut write FIcmpTimeOut;       property IcmpMaxHops : integer read FIcmpMaxHops write FIcmpMaxHops;     end; // --------------------------------------------------------------------------- implementation // ======================================== // Create the class and set defaults // ======================================== constructor TTraceRoute.Create; begin  IcmpTimeOut := 5000;  IcmpMaxHops := 40; end; // ============================================= // Use Indy component to ping hops to target // ============================================= procedure TTraceRoute.PingTarget; var wOldMode : DWORD; begin  Application.ProcessMessages;  inc(FCurrentTTL);  if FCurrentTTL < FIcmpMaxHops then begin    FICMP.TTL  := FCurrentTTL;    FICMP.ReceiveTimeout := FIcmpTimeOut;    FPingStart := GetTickCount;    wOldMode := SetErrorMode(SEM_FAILCRITICALERRORS);    try      FICMP.Ping;      ProcessResponse(FICMP.ReplyStatus);    except      FResults.Add('0.0.0.0;0;0;ERROR');    end;    SetErrorMode(wOldMode);  end  else    FResults.Add('0.0.0.0;0;0;MAX HOPS EXCEEDED'); end; // ============================================================ // Add the ping reply status data to the returned stringlist // ============================================================ procedure TTraceRoute.AddRoute(AResponseTime : DWORD;                               AStatus: TReplyStatus;                               const AInfo: string ); begin  FResults.Add(AStatus.FromIPAddress + ';' +               IntToStr(GetTickCount - AResponseTime) + ';' +               IntToStr(AStatus.TimeToLive) + ';' + AInfo); end; // ============================================================ // Process the ping reply status record and add to stringlist // ============================================================ procedure TTraceRoute.ProcessResponse(Status : TReplyStatus); begin  case Status.ReplyStatusType of    // Last Leg - Terminate Trace    rsECHO : AddRoute(FPingStart,Status,'OK');    // More Hops to go - Continue Pinging    rsErrorTTLExceeded :  begin                            AddRoute(FPingStart,Status,'OK');                            PingTarget;                          end;    // Error conditions - Terminate Trace    rsTimeOut : AddRoute(FPingStart,Status,'TIMEOUT');    rsErrorUnreachable : AddRoute(FPingStart,Status,'UNREACHABLE');    rsError : AddRoute(FPingStart,Status,'ERROR');  end; end; // ====================================================== // Trace route to target IP address // Results returned in semi-colon delimited stringlist // IP; TIME MS; TIME TO LIVE; STATUS // ====================================================== procedure TTraceRoute.Trace(const AIpAddress : string;                            AResultList : TStrings); begin  FICMP := TIdIcmpClient.Create(nil);  FICMP.Host := AIpAddress;  FResults := TStringList(AResultList);  FResults.Clear;  FCurrentTTL := 0;  PingTarget;  FICMP.Free; end; {eof} end. Delhpi3000 Добавлено @ 01:41 Предпросмотр/печать TRichEdit Чтобы вывести Rich Edit на любой канвас, нужно использовать стандартное сообщение EM_FORMATRANGE. lParam пареметр этого сообщения содержит указатель на структуру TFormatRange. Перед посылкой сообщения нужно заполнить эту структуру: hdc - контекст устройства, на который будет выводиться Rich Edit hdcTarget - контекст устройства, в соответствии с которым будет производиться форматирование текста rc - область, в которую будет выводиться Rich Edit. Единицы измерения - твипсы (twips). Twips = 1/1440 дюйма. rcPage - полная область вывода устройства (в твипсах) chrg - указывает диапазон выводимого текста chrg.cpMin и chrg.cpMax - позиции символов, определяющие кусок текста (не включая сами cpMin и cpMax)... Код function  PrintRTFToBitmap(ARichEdit : TRichEdit; ABitmap : TBitmap) : Longint; var range    : TFormatRange; begin FillChar(Range, SizeOf(TFormatRange), 0); // Rendering to the same DC we are measuring. Range.hdc        := ABitmap.Canvas.handle; Range.hdcTarget  := ABitmap.Canvas.Handle; // Set up the page. Range.rc.left    := 0; Range.rc.top     := 0; Range.rc.right   := ABitmap.Width * 1440 div Screen.PixelsPerInch; Range.rc.Bottom  := ABitmap.Height * 1440 div Screen.PixelsPerInch; // Default the range of text to print as the entire document. Range.chrg.cpMax := -1; Range.chrg.cpMin := 0; // format the text Result := SendMessage(ARichedit.Handle, EM_FORMATRANGE, 1, Longint(@Range)); // Free cached information SendMessage(ARichEdit.handle, EM_FORMATRANGE, 0,0); end; Следующий пример покажет, как вывести Rich Edit не только на любой канвас, но и также, как вывести только определённый кусок текста... Код function PrintToCanvas(ACanvas : TCanvas; FromChar, ToChar : integer;                      ARichEdit : TRichEdit; AWidth, AHeight : integer) : Longint; var Range    : TFormatRange; begin FillChar(Range, SizeOf(TFormatRange), 0); Range.hdc        := ACanvas.handle; Range.hdcTarget  := ACanvas.Handle; Range.rc.left    := 0; Range.rc.top     := 0; Range.rc.right   := AWidth * 1440 div Screen.PixelsPerInch; Range.rc.Bottom  := AHeight * 1440 div Screen.PixelsPerInch; Range.chrg.cpMax := ToChar; Range.chrg.cpMin := FromChar; Result := SendMessage(ARichedit.Handle, EM_FORMATRANGE, 1, Longint(@Range)); SendMessage(ARichEdit.handle, EM_FORMATRANGE, 0,0); end; А как вывести Rich-текст с фоновым рисунком ? Рисуем по-отдельности фоновый рисунок и содержимое TRichEdit, а потом их соединяем... Код procedure TForm1.Button2Click(Sender: TObject); var Bmp : TBitmap; begin Bmp := TBitmap.Create; bmp.Width := 300; bmp.Height := 300; PrintToCanvas(bmp.Canvas,2,5,RichEdit1,300,300); BitBlt(Image1.Picture.Bitmap.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,        bmp.Canvas.Handle, 0, 0, srcAND); Image1.Repaint; bmp.Free; end; DelphiPages Добавлено @ 01:42 Как узнать IP клиента и IP сервера для активного RAS-подключения ? Код uses Ras, RasError; type  TRASIP = record    dwSize: DWORD;    dwError: DWORD;    szIpAddress: packed array[0..RAS_MaxIpAddress] of AnsiChar;    szServerIpAddress: packed array[0..RAS_MaxIpAddress] of AnsiChar;  end; procedure GetDialUpIpAddress(var server, client: string); var  RASPppIp: TRASIP;  lpcp: DWORD;  ConnClientIP: array[0..RAS_MaxIpAddress] of Char;  ConnServerIP: array[0..RAS_MaxIpAddress] of Char;  Entries: PRasConn;  BufSize, NumberOfEntries, Res: DWORD;  RasConnHandle: THRasConn; begin  New(Entries);  BufSize := Sizeof(Entries^);  ZeroMemory(Entries, BufSize);  Entries^.dwSize := Sizeof(Entries^);  Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);  if Res = ERROR_BUFFER_TOO_SMALL then  begin    ReallocMem(Entries, BufSize);    ZeroMemory(Entries, BufSize);    Entries^.dwSize := Sizeof(Entries^);    Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);  end;  try    if (Res = 0) and (NumberOfEntries > 0) then RasConnHandle := Entries.hrasconn else exit  finally    FreeMem(Entries);  end;  FillChar(RASPppIp, SizeOf(RASPppIp), 0);  RASPppIp.dwSize := SizeOf(RASPppIp);  lpcp := RASPppIp.dwSize;  if RasGetProjectionInfo(RasConnHandle,    RASP_PppIp, @RasPppIp, lpcp) = 0 then  begin    Move(RASPppIp.szServerIpAddress,      ConnServerIP,      SizeOf(ConnServerIP));    Server := ConnServerIP;    Move(RASPppIp.szIpAddress,      ConnClientIP,      SizeOf(ConnClientIP));    client := ConnClientIP;  end; end; Delphi3000 Добавлено @ 01:43 Как узнать частоту обновления монитора ? Код function GetDisplayFrequency: Integer; var  DeviceMode: TDeviceMode; begin  EnumDisplaySettings(nil, Cardinal(-1), DeviceMode);  Result := DeviceMode.dmDisplayFrequency; end; Delphi3000 Добавлено @ 01:44 Как заблокировать доступ к дисководу ? В этом примере при нажатии на Button1 дисковод заблокируется, а при нажатии ОК - разблокируется... Код const  FILE_DEVICE_FILE_SYSTEM: Integer = $00000009;  METHOD_BUFFERED: Integer = $00000000;  FILE_ANY_ACCESS: Integer = $00000000; function CTL_CODE(DeviceType, FunctionNo, Method, Access: Integer): Integer; begin  Result := (DeviceType shl 16) or (Access shl 14) or (FunctionNo shl 2) or (Method); end; procedure TForm1.Button1Click(Sender: TObject); var  LHandle: THandle;  BytesReturned: Cardinal;  MsgBuf: PChar;  FSCTL_LOCK_VOLUME: Integer; begin  FSCTL_LOCK_VOLUME := CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 6,                                                   METHOD_BUFFERED, FILE_ANY_ACCESS);  LHandle := CreateFile('\\.\A:', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ                       or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or                       FILE_FLAG_DELETE_ON_CLOSE, 0);  if LHandle <> 0 then  begin    if DeviceIOControl(LHandle, FSCTL_LOCK_VOLUME, nil, 0, nil, 0, BytesReturned, nil) then      ShowMessage('Дисковод заблокирован. Нажмите ОК для разблокирования.')    else    begin      if FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or           FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError(), 0, @MsgBuf, 0, nil) > 0 then      begin        ShowMessage('Ошибка DeviceIOControl: ' + MsgBuf);        LocalFree(Cardinal(MsgBuf));      end      else        ShowMessage('Ошибка при вызове DeviceIOControl!');    end;    CloseHandle(LHandle);  end  else    ShowMessage('Ошибка при вызове CreateFile!'); end; DelphiPool Добавлено @ 01:45 Antivirus API Microsoft Antivirus API позволяет создавать приложения для сканирования документов MS Office перед их открытием (а также сканирование закачек IE, содержащих код). Код unit msoav; interface uses Windows, SysUtils, ActiveX, ComObj, Classes; const IID_IOfficeAntiVirus : TGUID =    '{56FFCC30-D398-11d0-B2AE-00A0C908FA49}'; //DEFINE_GUID(IID_IOfficeAntiVirus, //0x56ffcc30, 0xd398, 0x11d0, 0xb2, 0xae, 0x0, 0xa0, 0xc9, 0x8, 0xfa, 0x49); CATID_MSOfficeAntiVirus : TGUID = '{56FFCC30-D398-11d0-B2AE-00A0C908FA49}'; //DEFINE_GUID(CATID_MSOfficeAntiVirus, //0x56ffcc30, 0xd398, 0x11d0, 0xb2, 0xae, 0x0, 0xa0, 0xc9, 0x8, 0xfa, 0x49); type TInfoStruct = record  fIsFile : boolean;  fIsReadOnly : boolean;  fIsInstalled : boolean;  fIsHTTPDownload : boolean; end; //Contains information about the file to be scanned. { * cbSize      - Integer value that specifies the size of an MSOAVINFO structure. * hWnd        - Handle to the parent window of the Microsoft® Office 2000 application. * pwzFullPath - Address of a wide character string that contains the full                  path of the file about to be opened. * lpStg       - Address of the OLE storage location of the file about to be opened. * pwzHostName - Address of a wide character string that contains the host                 application name for the antivirus scanner user interface. * pwzOrigURL  - Address of a wide character string that contains the URL of the                 origin of a downloaded file. } TMsoavinfo = record  cbSize : integer;  info   : ULONG;  wnd : HWND;  FullPath : Pointer;  pwzHostName : PWChar;  pwzOrigURL  : PWChar; end; //This is the interface an antivirus scanner uses to interact with a host application. IOfficeAntiVirus = interface(IUnknown) ['{56FFCC30-D398-11d0-B2AE-00A0C908FA49}']  function Scan(pmsoavinfo : PChar) : HResult; stdcall; end; function TestBit(const Value: Cardinal; const Bit: byte): Boolean; procedure GetRegisteredAntiviruses(ProgIDs: TStrings); implementation function TestBit(const Value: Cardinal; const Bit: byte): Boolean; begin  Result := (Value and (1 shl (Bit mod 32))) <> 0; end; procedure GetRegisteredAntiviruses(ProgIDs: TStrings); var  CatInformation: ICatInformation;  Enum: IEnumGUID;  CLSID: TGUID;  nFetched: Cardinal;  CatId: TGUID; begin  CatInformation := CreateComObject(CLSID_StdComponentCategoryMgr) as ICatInformation;  CatId := CATID_MSOfficeAntiVirus;  OleCheck(CatInformation.EnumClassesOfCategories(1, @CatId, 0, nil, Enum));  ProgIDs.BeginUpdate;  try    ProgIDs.Clear;    while (Enum.Next(1, CLSID, nFetched) = S_OK) do begin      ProgIDs.Add(GuidToString(clsid));    end;  finally    ProgIDs.EndUpdate;  end; end; end. Now I will show a small example how to use IOfficeAntiVirus interface to implement own antivirus program for Microsoft Office.  library msoavtest; uses  ComServ,  msoav,  umsoavtest; exports  DllGetClassObject,  DllCanUnloadNow,  DllRegisterServer,  DllUnregisterServer; begin end. unit umsoavtest; interface uses  Windows, ActiveX, ComObj, ShlObj, Dialogs, msoav; type  TMSOTest = class(TComObject, IOfficeAntiVirus)  protected   function Scan(pmsoavinfo : PChar) : HResult; stdcall;  end; const  Class_MsoTest: TGUID = '{F56BE781-C8BE-11D7-8601-00E0184D1E9D}'; implementation uses ComServ, SysUtils, ShellApi, Registry; procedure UpdateCat(Register: Boolean;  const ClassID:  string); const  SCatImplBaseKey = 'CLSID\%s\Implemented Categories';  SCatImplKey = SCatImplBaseKey + '\%s'; var  CatReg: ICatRegister;  Rslt: HResult;  CatInfo: TCATEGORYINFO;  Description: string; begin  Rslt := CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,    CLSCTX_INPROC_SERVER, ICatRegister, CatReg);  if Succeeded(Rslt) then  begin    if Register then    begin      CatInfo.catid := CATID_MSOfficeAntiVirus;      CatInfo.lcid := $0409;      StringToWideChar('', CatInfo.szDescription,        Length('') + 1);      OleCheck(CatReg.RegisterCategories(1, @CatInfo));      OleCheck(CatReg.RegisterClassImplCategories(StringToGUID(ClassID), 1, @CATID_MSOfficeAntiVirus));    end else    begin      OleCheck(CatReg.UnRegisterClassImplCategories(StringToGUID(ClassID), 1, @CATID_MSOfficeAntiVirus));      DeleteRegKey(Format(SCatImplBaseKey, [ClassID]));    end;  end else  begin    if Register then    begin      CreateRegKey('Component Categories\' + GUIDToString(CATID_MSOfficeAntiVirus), '409', '');      CreateRegKey(Format(SCatImplKey, [ClassID, GUIDToString(CATID_MSOfficeAntiVirus)]), '', '');    end else    begin      DeleteRegKey(Format(SCatImplKey, [ClassID, GUIDToString(CATID_MSOfficeAntiVirus)]));      DeleteRegKey(Format(SCatImplBaseKey, [ClassID]));    end;  end;  if Register then  begin    Description := GetRegStringValue('CLSID\' + ClassID, '');    CreateRegKey('AppID\' + ClassID, '', Description);    CreateRegKey('CLSID\' + ClassID, 'AppID', ClassID);  end else    DeleteRegKey('AppID\' + ClassID); end; { TMSOTest } function TMSOTest.Scan(pmsoavinfo: PChar): HResult; var Info   : TMsoavinfo; Struct : TInfoStruct; p : pointer; begin  p := pointer(pmsoavinfo);  if not Assigned(p) then   begin     //no information available     Result := S_OK;     Exit;   end;  Move(P^, Info, SizeOf(Tmsoavinfo));  if Info.cbSize <> SizeOf(Tmsoavinfo) then   begin     //wrong size of the structure     Result := S_OK;     Exit;   end;  Struct.fIsFile := TestBit(Info.Info, 0);  Struct.fIsReadOnly := TestBit(Info.Info, 1);  Struct.fIsInstalled := TestBit(Info.Info, 2);  Struct.fIsHTTPDownload :=  TestBit(Info.Info, 3);  if struct.fIsFile then   begin     MessageDlg(PWChar(Info.FullPath), mtWarning, [mbOK], 0);   end;  Result := S_OK; end; type  TMSOAvFactory = class(TComObjectFactory)  public    procedure UpdateRegistry(Register: Boolean); override;  end; procedure TMSOAVFactory.UpdateRegistry(Register: Boolean); var  ClassID: string; begin  ClassID := GUIDToString(Class_MsoTest);  if Register then  begin    inherited UpdateRegistry(Register);    UpdateCat(true, ClassID);  end  else  begin    UpdateCat(false, ClassID);    inherited UpdateRegistry(Register);  end; end; initialization  TComObjectFactory.Create(ComServer, TMsoTest, Class_MsoTest,    'MsoTest', '', ciMultiInstance, tmApartment); end. Delphi3000

Автор: RA 25.11.2004, 06:00

Работа с окнами Пример процедуры убивающей таймеры по заголовку окна в чужих приложениях написанных на Delphi Код var  Hinst : THandle;  WndArr : array of THandle;  Wnd : THandle; ...... Procedure KillDelphiWndTimers(const AppCaption:string); var  i : integer; function GetTimerWindows(Handle: HWND; Info: Pointer): BOOL; stdcall; const sClName ='TPUtilWindow'; var s : String; begin Result := True; SetLength(s,Length(sClName)+1); GetClassName(Handle, PChar(s),Length(s)); SetLength(s,Length(sClName)); // Ëþáèò çàïèõèâàòü ñèâîë #0 :) if (GetWindowLong(Handle, GWL_HINSTANCE) =  Hinst )  and  (s=sClName) then   begin     SetLength(WndArr,High(WndArr)+2);     WndArr[High(WndArr)]:=Handle;   end; end; begin Wnd:=FindWindow(nil,Pchar(AppCaption)); if Wnd=0 then Exit; hinst:=GetWindowLong(Wnd, GWL_HINSTANCE); EnumWindows(@GetTimerWindows,0); for i:=0 to High(WndArr) do KillTimer(WndArr[i],1); end; Присвоение форме выбранного окна свойства Disabled / Enabled Код {в конце процедуры: false для запрета true для разрешения} EnableWindow(FindWindow(Nil,Pchar('Название Окна')), false); Отображение формы выбранного окна Код { SW_MAXIMIZE - Развёрнуть форму SW_MINIMIZE - Минимизировать форму SW_SHOW - Показать форму SW_HIDE - Спрятать форму } ShowWindow(FindWindow(Nil,Pchar('Название Окна')),SW_MAXIMIZE); Запретить в выбранном окне кнопку закрытия x Код   EnableMenuItem(GetSystemMenu(FindWindow(Nil, Pchar('Название Окна')),False)   ,SC_CLOSE,MF_BYCOMMAND or MF_GRAYED); Закрыть выбранное окно Код PostMessage(FindWindow(Nil, Pchar('Название Окна')), WM_QUIT, 0, 0); Сделать форму выбранного окна поверх остальных Код SetForegroundWindow(FindWindow(Nil,Pchar('Название Окна'))); Поменять заголовок выбранного окна Код  SetWindowText(FindWindow(Nil,Pchar('Старый Заголовок')),pchar('Новый заголовок')); Форма Как выбрать и установить уровень прозрачности формы: Код  Form1.AlphaBlendValue := 200 {Уровень прозрачности};  Form1.AlphaBlend := True; Атомы Запись, чтение и удаление информации. Код {Act: 0 - Очистка атомов, 1 - чтение атомов, 2 - запись атомов} {Uniq - Уникальный идентификатор} {AtomNfo - Информация для записи} Function AtomDo(Act:integer;Uniq,AtomNfo:string);  Procedure CleanAtoms;  var P:PChar;   i:Word;  begin   GetMem(p, 256);     For i:=0 to $FFFF do     begin       GlobalGetAtomName(i, p, 255);      if StrPos(p, PChar(Uniq))<>nil then GlobalDeleteAtom(i);     end;    FreeMem(p);  end;  Function ReadAtom:string;  var P:PChar;   i:Word;   begin     GetMem(p, 256);     For i:=0 to $FFFF do    begin     GlobalGetAtomName(i, p, 255);     if StrPos(p, PChar(Uniq))<>nil then break;    end;       result:=StrPas(p+length(Uniq));       FreeMem(p);   end; begin   case Act of   0 : CleanAtoms;   1 : Result:=ReadAtom;   2 : begin       CleanAtoms;       GlobalAddAtom(PChar(Uniq+AtomNfo));       end; end;

Автор: Yanis 4.12.2004, 23:43

Извините, что пишу в эту ветку. Но приходится. У меня есть предложение. (Я смотрю что наполнение DRKB идёт медленно, особенно последней версии.) Может стоить создать DRKB4C++!? Ведь найти инфу по интересующему вопросу, корая содержится в DRKB относительно C++ сложнее. Добавлено @ 23:49 Oops! http://forum.vingrad.ru/index.php?showtopic=33870 Только заметил

Автор: Vit 5.12.2004, 02:56

Цитата(Yanis @ 4.12.2004, 14:43) Извините, что пишу в эту ветку. Но приходится. У меня есть предложение. (Я смотрю что наполнение DRKB идёт медленно, особенно последней версии.) Может стоить создать DRKB4C++!? Ведь найти инфу по интересующему вопросу, корая содержится в DRKB относительно C++ сложнее. Я не против. Могу дать исходники DRKB - переделывайте под C++

Автор: Yanis 5.12.2004, 18:53

Цитата(Vit @ 5.12.2004, 02:56) Я не против. Могу дать исходники DRKB - переделывайте под C++ Видимо не получится. Не чувтвуется интузиазм в этих словах

Автор: Alex 5.12.2004, 19:09

Цитата(Yanis @ 5.12.2004, 18:53) Видимо не получится. Не чувтвуется интузиазм в этих словах Извини, а ты думал vit будет вам под с++ делать

Автор: Vit 6.12.2004, 05:16

Что-то я вообще туго улавливаю смысл последнее время... Смотрим цепь обсуждений: Цитата(Yanis @ 4.12.2004, 14:43) Я смотрю что наполнение DRKB идёт медленно, особенно последней версии Цитата(Yanis @ 4.12.2004, 14:43) Может стоить создать DRKB4C++!? Цитата(Vit @ 4.12.2004, 17:56) Я не против. Могу дать исходники DRKB - переделывайте под C++ Цитата(Yanis @ 5.12.2004, 09:53) Видимо не получится. Не чувтвуется интузиазм в этих словах Неужели господин Yanis всерьёз полагает что перевод на C++ должен как-то ускорить выход очередной версии DRKB или полагает что наполнение DRKB идёт медленно из-за того что у меня просто слишком много свободного времени, и меня просто надо загрузить для ускорения процесса? Это прямо как из детской сказки: "Давай ты меня понесёшь на себе а я буду тебе дорогу показывать и идти тебе будет легче..."

Автор: Fedor 11.12.2004, 14:15

Вот немного по алгоритмам теории графов - не с форума, а с моей квалификационной работы. Правда, на украинском языке. Если понадобится, могу перевести на русский. Цитата АЛГОРИТМИ ТЕОРІЇ ГРАФІВ Основні визначення теорії графів Орієнтований граф, як пишуть у [1] – це «пара (V, E), де V – кінцева множина, а E – бінарне відношення на V, тобто підмножина множини V*V… …множину V називають множиною вершин графа, а множину E – множиною ребер». У неорієнтованому графі множина V складається з неупорядкованих пар вершин. Парою називається множина {u,v}, де u і v належать V. Якщо в графі є ребро (u,v), то говорять, що вершина u суміжна з вершиною v. Для неорієнтованих графів відношення суміжності є симетричним. Шлях довжини k з вершини u у вершину v визначається як послідовність вершин v0, v1, v2, … vk, у який v0 = u, vk = v, а (vi-1, vi) – ребро графа. Циклом в орієнтованому графі називається шлях, у якому початкова вершина збігається з кінцевою і який містить хоча б одне ребро. Граф, у якому немає циклів, називається ациклічним. Представлення графів Є два стандартних способи представлення графів: як список суміжних вершин чи як матрицю суміжності. Обидва способи мають свої плюси і недоліки. Список суміжних вершин дуже зручний при представленні розріджених графів. Він дає вигідне зменшення займаного обсягу пам'яті. Але при цьому цей спосіб не дає можливості швидко перевірити наявність ребра між двома довільними вершинами. Це представлення графу використовує масив списків по одному списку для кожної вершини. Список зберігає усі вершини, суміжні з даною вершиною в довільному порядку. Матриця суміжності займає більший обсяг пам'яті, але зручна для представлення щільних графів. Тут кожен елемент Mij матриці позначає наявність ребра межу вершиною i та вершиною j. Якщо граф – зважений, то Mij може позначати вагу ребра (i,j). Алгоритм пошуку в ширину Алгоритм пошуку в ширину (Breadth-first search) – один з базисних алгоритмів, що є основою багатьох інших. Наприклад, алгоритм Дейкстри пошуку найкоротших шляхів з однієї вершини й алгоритм Прима пошуку мінімального покриваючого дерева можуть розглядатися як узагальнення пошуку в ширину.. Нехай заданий граф G і фіксована початкова вершина s. Алгоритм пошуку в ширину перелічує всі досяжні з s (якщо йти по ребрах) вершини в порядку збільшення відстані від s. У процесі пошуку з графу виділяється частина, що називається «деревом пошуку в ширину» з коренем s. Вона містить усі досяжні з s вершини (і тільки їх). Для кожної з них шлях з кореня в дереві пошуку буде одним з найкоротших шляхів до s. Алгоритм можна застосувати і до орієнтованих, і до неорієнтованих графів. Назва пояснюється тим, що в процесі пошуку ми йдемо в широчінь, а не в глиб (з початку переглядаємо сусідні вершини, потім сусідів сусідів, і т.д.). Для наочності будемо вважати, що в процесі роботи алгоритму вершини графа можуть бути білими, сірими і чорними. Спочатку вони всі білі, а в ході роботи алгоритму біла вершина може стати сірою, сіра - чорною, але не навпаки. Зустрівши нову вершину, алгоритм пошуку фарбує її, так що сірі і чорні вершини - уже виявлені вершини. Різниця між сірими і чорними вершинами використовується алгоритмом для керування порядком обходу: сірі вершини утворять "лінію фронту", а чорні - "тил". Таким чином, тільки сірі вершини можуть мати суміжні невиявлені вершини. Спочатку дерево пошуку складається тільки з початкової вершини s. Як тільки алгоритм виявляє нову вершину v, суміжну з раніше знайденою вершиною u, вершина v разом з ребром (u, v) додається до дерева пошуку, стаючи дитиною вершини u, а u стає батьком v. Кожна вершина виявляється тільки один раз, так що двох батьків у вершини бути не може. Оцінюючи складність цього алгоритму, ми зауважуємо, що вершини тільки сутеніють, отже, кожна вершина обробляється тільки один раз. При цьому для обходу суміжних вершин для даної вершини використовується часу O(E). Отже, обчислювальна складність алгоритму пошуку в ширину – O(V+E), де V – кількість вершин у графі, а E – кількість ребер. Алгоритм пошуку в глибину Пошук у глибину – ще один спосіб обходу графу. Він застосовується в таких алгоритмах, як алгоритм топологічного сортування, алгоритм пошуку сильно зв'язаних компонентів. Стратегія пошуку в глибину така: йти вглиб, поки це можливо (є непройдені вихідні ребра), повертатися і шукати інший шлях, коли таких ребер немає. Якщо після цього залишаються недоторкані вершини - можна вибрати одну з них і повторювати процес доти, поки залишаються невиявлені вершини. Знайшовши уперше вершину v, суміжну з u, ми відзначаємо цю подію, записуючи в поле ?[v] значення u. Утворюється дерево чи кілька дерев. Як і пошук у ширину, алгоритм пошуку в глибину використовує кольори вершин. Спочатку усі вершини - білі. При виявленні нової вершини, вона фарбується в сірий колір. Коли вершина цілком оброблена, вона фарбується в чорний колір. Крім цього пошук у глибину ставить на вершинах мітки часу. Кожна вершина має дві мітки: d[v] показує, коли вершина була виявлена, f[v] - коли оброблена. Ці мітки використовуються в багатьох алгоритмах на графах. Під час виконання цього алгоритму, обробка кожної вершини відбувається рівно один раз. Отже, складність роботи даного алгоритму становить O(V+E), де V – кількість вершин у графі, а E – кількість ребер. Алгоритм Дейкстри пошуку найкоротших шляхів Уявимо собі карту автомобільних шляхів України. Як знайти найкоротший шлях із Дніпропетровська в Київ? Можна, звичайно, перебрати всі можливі варіанти і вибрати мінімальний з них. Але тоді ми одержуємо мільйони свідомо невірних операцій (наприклад, навіщо нам їхати з Дніпропетровська в Київ через Донецьк, що знаходиться зовсім в іншому боці). Далі буде розглянутий спосіб ефективного рішення цієї задачі. Тут буде розглядатися тільки пошук найкоротших шляхів з однієї вершини: даний зважений граф G і початкова вершина s. Потрібно знайти всі найкоротші шляхи з s в усі вершини графу. Алгоритм Дейкстри здатний знайти найкоротший шлях тільки для графів, у яких усі ребра недодатньої ваги. Багато алгоритмів пошуку найкоротших шляхів використовують особливу техніку – техніку релаксації. І алгоритм Дейскстри – не виключення. Техніка релаксації полягає в наступному: для кожної вершини v ми зберігаємо деяке число d[v], що є верхньою оцінкою ваги найкоротшого шляху з s у v. Початкове значення оцінки найкоротшого шляху і масиву ? (масиву предків) задається наступною процедурою: Initialize-Single-Source(G, s) 1 for (для) усіх вершин v 2  do d[v] = ? 3      ?[v] = NIL 4 d[s] = 0 Релаксація ребра (u,v) полягає в наступному: значення d[v] зменшується до d[u]+w(u,v) (якщо друге значення менше попереднього). При цьому d[v] залишається верхньою оцінкою. Relax(u, v, w) 1 if d[v] > d[u] + w(u,w) 2  then d[v] = d[u] + w(u,w) 3          ?[v] = u По своїй суттевості, алгоритм Дейкстри є жадним алгоритмом. У процесі роботи алгоритму Дейкстри підтримується множина S, що складається з вершин v, для яких знайдений найкоротший шлях. Алгоритм вибирає вершину u з найменшим d[u], додає її до множини S і здійснює релаксацію всіх ребер, що виходять з u, після чого цикл повторюється. Складність роботи алгоритму Дейкстри становить O(V2) Пошук максимального паросполучення Нехай G(V, E) - неорієнтований граф. Паросполученням назвемо множину ребер M, що не мають спільних кінців (кожна вершина v з V є кінцем максимум одного ребра з M). Будемо говорити, що вершина v з V входить у паросполучення M, якщо в M є ребро з кінцем v. У противному випадку v вільна. Максимальне паросполучення - це паросполучення M, що містить максимально можливе число ребер. Для рішення задачі про найбільше паросполучення використовується метод ланцюгів, що чергуються. Нехай M - паросполучення в двочастковому графі G. Ланцюг, у який по черзі входять ребра з M і з "не-M", назвемо ланцюгом, що чергується. Вершини, инцидентні ребрам з M, назвемо насиченими. Чергуючийся відносно M ланцюг з ненасиченими вершинами називається ланцюгом, що збільшує, відносно M. Паросполучення M є максимальним тоді і тільки тоді, коли немає збільшуючих відносно M ланцюгів Для задач про максимальне паросполучення є безліч метафор. Ось одна з них: є множина чоловіків і множина наречених. Ребро (u,v) означає, що чоловік u і наречена v згодні оженитися. Максимальне паросполучення доставляє ЗАГСу більше всього роботи. Алгоритм пошуку максимального паросполучення такий: 1. Ініціалізація 2. Побудова жадібного паросполучення. 3. У циклі по i з I' застосувати алгоритм знаходження всіх досяжних вершин з                   i. Якщо серед них виявиться вершина з J', то збільшити ланцюг. 4. Якщо множини I' і J' непорожні і на кроці 3 удалося збільшити ланцюг, то                  перейти до 3 5. Видати рішення Тут I' і J' - множини ненасичених вершин із двох часток графа. "Збільшити ланцюг" - говорячи простою мовою - означає розгорнути ребра графа. Когда делал квалификационную, материалы брал в основном из Кормен, Лейзерсон, Ревест - Алгоритмы: построение и анализ

Автор: Vit 11.12.2004, 23:14

Да, неплохо было бы перевести... Спасибо

Автор: Akella 24.12.2004, 10:52

есть интересная ссылка: http://www.kib.ru/lib/resources/src19/Secrets_Delphi_7_Book/ По крайней мере там можно немного прочитать о RaveReports Может есть смысл просто "выкусить" оттуда инфо, скажите, какие темы наиболее востребованы

Автор: Vit 24.12.2004, 15:14

посмотрю

Автор: Akella 24.12.2004, 17:40

Vit, я могу выложить примеры работы с MS Agent, если конечно Microsoft не расстроиться

Автор: Akella 25.12.2004, 10:58

Есть предлежение, включить примеры шифрования, например Алгоритм MD5 шифрования (хэширования) Код Function md5(s:string):string;   var a:array[0..15] of byte;      i:integer;   LenHi, LenLo: longword;   Index: DWord;   HashBuffer: array[0..63] of byte;   CurrentHash: array[0..3] of DWord;   procedure Burn;   begin     LenHi:= 0; LenLo:= 0;     Index:= 0;     FillChar(HashBuffer,Sizeof(HashBuffer),0);     FillChar(CurrentHash,Sizeof(CurrentHash),0);   end;   procedure Init;   begin    Burn;    CurrentHash[0]:= $67452301;    CurrentHash[1]:= $efcdab89;    CurrentHash[2]:= $98badcfe;    CurrentHash[3]:= $10325476;   end;   function LRot32(a, b: longword): longword;   begin    Result:= (a shl b) or (a shr (32-b));   end;   procedure Compress;   var    Data: array[0..15] of dword;    A, B, C, D: dword;   begin    Move(HashBuffer,Data,Sizeof(Data));    A:= CurrentHash[0];    B:= CurrentHash[1];    C:= CurrentHash[2];    D:= CurrentHash[3];    A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 0] + $d76aa478,7);    D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 1] + $e8c7b756,12);    C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[ 2] + $242070db,17);    B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[ 3] + $c1bdceee,22);    A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 4] + $f57c0faf,7);    D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 5] + $4787c62a,12);    C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[ 6] + $a8304613,17);    B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[ 7] + $fd469501,22);    A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 8] + $698098d8,7);    D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 9] + $8b44f7af,12);    C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[10] + $ffff5bb1,17);    B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[11] + $895cd7be,22);    A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[12] + $6b901122,7);    D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[13] + $fd987193,12);    C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[14] + $a679438e,17);    B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[15] + $49b40821,22);    A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 1] + $f61e2562,5);    D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[ 6] + $c040b340,9);    C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[11] + $265e5a51,14);    B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 0] + $e9b6c7aa,20);    A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 5] + $d62f105d,5);    D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[10] + $02441453,9);    C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[15] + $d8a1e681,14);    B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 4] + $e7d3fbc8,20);    A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 9] + $21e1cde6,5);    D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[14] + $c33707d6,9);    C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[ 3] + $f4d50d87,14);    B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 8] + $455a14ed,20);    A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[13] + $a9e3e905,5);    D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[ 2] + $fcefa3f8,9);    C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[ 7] + $676f02d9,14);    B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[12] + $8d2a4c8a,20);    A:= B + LRot32(A + (B xor C xor D) + Data[ 5] + $fffa3942,4);    D:= A + LRot32(D + (A xor B xor C) + Data[ 8] + $8771f681,11);    C:= D + LRot32(C + (D xor A xor B) + Data[11] + $6d9d6122,16);    B:= C + LRot32(B + (C xor D xor A) + Data[14] + $fde5380c,23);    A:= B + LRot32(A + (B xor C xor D) + Data[ 1] + $a4beea44,4);    D:= A + LRot32(D + (A xor B xor C) + Data[ 4] + $4bdecfa9,11);    C:= D + LRot32(C + (D xor A xor B) + Data[ 7] + $f6bb4b60,16);    B:= C + LRot32(B + (C xor D xor A) + Data[10] + $bebfbc70,23);    A:= B + LRot32(A + (B xor C xor D) + Data[13] + $289b7ec6,4);    D:= A + LRot32(D + (A xor B xor C) + Data[ 0] + $eaa127fa,11);    C:= D + LRot32(C + (D xor A xor B) + Data[ 3] + $d4ef3085,16);    B:= C + LRot32(B + (C xor D xor A) + Data[ 6] + $04881d05,23);    A:= B + LRot32(A + (B xor C xor D) + Data[ 9] + $d9d4d039,4);    D:= A + LRot32(D + (A xor B xor C) + Data[12] + $e6db99e5,11);    C:= D + LRot32(C + (D xor A xor B) + Data[15] + $1fa27cf8,16);    B:= C + LRot32(B + (C xor D xor A) + Data[ 2] + $c4ac5665,23);    A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 0] + $f4292244,6);    D:= A + LRot32(D + (B xor (A or (not C))) + Data[ 7] + $432aff97,10);    C:= D + LRot32(C + (A xor (D or (not B))) + Data[14] + $ab9423a7,15);    B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 5] + $fc93a039,21);    A:= B + LRot32(A + (C xor (B or (not D))) + Data[12] + $655b59c3,6);    D:= A + LRot32(D + (B xor (A or (not C))) + Data[ 3] + $8f0ccc92,10);    C:= D + LRot32(C + (A xor (D or (not B))) + Data[10] + $ffeff47d,15);    B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 1] + $85845dd1,21);    A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 8] + $6fa87e4f,6);    D:= A + LRot32(D + (B xor (A or (not C))) + Data[15] + $fe2ce6e0,10);    C:= D + LRot32(C + (A xor (D or (not B))) + Data[ 6] + $a3014314,15);    B:= C + LRot32(B + (D xor (C or (not A))) + Data[13] + $4e0811a1,21);    A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 4] + $f7537e82,6);    D:= A + LRot32(D + (B xor (A or (not C))) + Data[11] + $bd3af235,10);    C:= D + LRot32(C + (A xor (D or (not B))) + Data[ 2] + $2ad7d2bb,15);    B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 9] + $eb86d391,21);    Inc(CurrentHash[0],A);    Inc(CurrentHash[1],B);    Inc(CurrentHash[2],C);    Inc(CurrentHash[3],D);    Index:= 0;    FillChar(HashBuffer,Sizeof(HashBuffer),0);   end;   procedure Update(const Buffer; Size: longword);   var    PBuf: ^byte;   begin    Inc(LenHi,Size shr 29);    Inc(LenLo,Size*8);    if LenLo< (Size*8) then      Inc(LenHi);    PBuf:= @Buffer;    while Size> 0 do    begin      if (Sizeof(HashBuffer)-Index)<= DWord(Size) then      begin        Move(PBuf^,HashBuffer[Index],Sizeof(HashBuffer)-Index);        Dec(Size,Sizeof(HashBuffer)-Index);        Inc(PBuf,Sizeof(HashBuffer)-Index);        Compress;      end      else      begin        Move(PBuf^,HashBuffer[Index],Size);        Inc(Index,Size);        Size:= 0;      end;    end;   end;   procedure Final(var Digest);   begin    HashBuffer[Index]:= $80;    if Index>= 56 then Compress;    PDWord(@HashBuffer[56])^:= LenLo;    PDWord(@HashBuffer[60])^:= LenHi;    Compress;    Move(CurrentHash,Digest,Sizeof(CurrentHash));    Burn;   end;   begin   Init;   Update(s[1],Length(s));   Final(a);   result:='';   for i:=0 to 15 do    result:=result+IntToHex(a[i],0);   Burn;   end; Автор Vit.

Автор: Alex 25.12.2004, 11:00

dsergey, он давно включен.

Автор: Akella 25.12.2004, 11:04

да я не к тому, что именно этот код нужно включать в новую версию, я просто привел пример. Когда-то я искал алгоритмы шифрования, создание серийных номеров и т.к., читал об "антивзомах", но информации нарыл малова-то Добавлено @ 11:12 можно добаить, наверное что-нибудь о сжатии

Автор: Akella 25.12.2004, 11:17

в DRKB есть статья создаем свой unrar, используя unrar.dll на форуме где-то был пример использования Кладем на форму кнопку и листбокс Код unit Unit1; interface uses  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  Dialogs, StdCtrls,unrars; type  TForm1 = class(TForm)    Button1: TButton;    ListBox1: TListBox;    procedure Button1Click(Sender: TObject);    procedure FormCreate(Sender: TObject);  private    { Private declarations }  public    { Public declarations }  end; var  Form1: TForm1;  pathstarts:string; implementation {$R *.dfm} procedure unrarss(ArcName,path:Pchar); var   st1:string;   OperBegin, OperEnd: TTimeStamp;   Total: LongWord;   hArcData:THandle;   RHCode,PFCode :integer;   CmtBuf:array [0..16384] of char;   HeaderData: RARHeaderData;   OpenArchiveData: RAROpenArchiveData; begin   if not fileexists(ArcName) then   begin   ShowMessage ('Нет Файла '+ArcName);   Exit;   end;   OpenArchiveData.ArcName:=ArcName;   OpenArchiveData.CmtBuf:=CmtBuf;   OpenArchiveData.CmtBufSize:=sizeof(CmtBuf);   OpenArchiveData.OpenMode:=RAR_OM_EXTRACT;   hArcData:=RAROpenArchive(OpenArchiveData);   RARSetPassword(hArcData,'000');   OperBegin:=DateTimeToTimeStamp(Now);   RHCode := 0; while (RHCode = 0) do begin PFCode:=RARProcessFile(hArcData,RAR_EXTRACT,path,nil); RHCode:=RARReadHeader(hArcData,HeaderData); if Pos('\',HeaderData.FileName)>0 then begin Form1.Listbox1.Items.Add(HeaderData.FileName); Form1.ListBox1.ItemIndex:=Form1.ListBox1.Items.Count-1; End; OperEnd:=DateTimeToTimeStamp(Now); Total := OperEnd.Time - OperBegin.Time; if Total=0 then Total:=1; Application.ProcessMessages; end; Str(RHCode,st1); if RhCode<>10 then ShowMessage('Ошибка распаковки Код:'+St1+#10+#13+'Файл:'+ArcName); RARCloseArchive(hArcData); end; procedure TForm1.Button1Click(Sender: TObject); begin ListBox1.Clear; unrarss(pchar(pathstarts+'rar\Izone300.rar'),pchar(pathstarts+'rar\unpack')); end; procedure TForm1.FormCreate(Sender: TObject); begin pathstarts:=ExtractFileDir(Paramstr(0)); if pathstarts<>'' then if pathstarts[length(pathstarts)]<>'\' then pathstarts:=pathstarts+'\'; end; end.

Автор: Alex 25.12.2004, 11:21

dsergey, дело в том, что в DRKB попадает почти весь материал, который виту или был прислан или он его сам нашел. Если его там нет, то значит, его никто не прислал или вит сам, не нашел. Делать заказы на добавление той или иной информации не нужно, если у вас есть примеры, то выкладывайте их, и я думаю, вит с радостью, их разместит. А говорить, хорошо бы добавить то или другое не нужно. Специально искать, материал по конкретной тематике я думаю, вит не будет т.к. при составлении DRKB и так дел хватает.

Автор: Akella 25.12.2004, 11:28

Хоть в DRKB есть инфо об использовании Excel`я, могу выложить свои примеры работы с Excel`ем `97, XP,2003 Импорт и экспорт данных, обрамление ячеек, размеры ячеек, поиск рабочих книг и листов в рабочих книгах в открытом Excel`e, поиск информмации, поиск последней заполненной ячейки, открытие, корректное закрытие Excel`я, установка формата (числовой, текстовый и т.д.) ячейки, удаление столбцов строк. Ну, до понедельника.

Автор: Alex 25.12.2004, 12:02

dsergey, выкладывай.

Автор: Akella 27.12.2004, 10:28

Примеры работы с MS Excel в секции uses стоит так ExcelXP,{Excel2000, Excel97} крайней мере у меня, т.к. некоторые параметры при работе с разными версиями отличаются, например при открытии файла в версии XP больше параметров, чем в версии `97. На форме лежит компонента Ex1 типа TExcelApplication со страницы Servers, свойства AutoConnect и AutoQuit :=False, свойство ConnectKind:=ckRunningOrNew, Код //объявления переменных var WorkBk : _WorkBook; //  определяем WorkBook WorkSheet : _WorkSheet; //  определяем WorkSheet Range:OleVariant;// begin ...     Ex1.Connect;//открываем сам Excel     //открываем существующий файл, в разных версиях разное кол-во параметров     Ex1.Workbooks.Open(FileName,EmptyParam,EmptyParam,EmptyParam,EmptyParam,       EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam, EmptyParam,EmptyParam,       EmptyParam,EmptyParam,EmptyParam, LOCALE_USER_DEFAULT); //параметры для версии XP - имя файла, пути на ссылки в файле(UpdateLinks),Откывать ли //только для чтения, Формат, Пароль, WriteResPassword - ?, Игнорировать ли рекомендации //только для чтения, Origin - ?, Delimiter - символ-разделитель целой и дробной частей, Editable-?     Ex1.Application.EnableEvents := false;//отключаем реакцию Excel`я на события //так ищем название рабочей книги, т.к. Excel может уже быть открыт с другой книгой //поиск начинаем с единицы   For i:=1 to ex1.Workbooks.Count do begin     if ex1.Workbooks.Item[i].Name='MyFile.xls' then break;   end;  // Выбираем WorkBook   WorkBk := ex1.WorkBooks.Item[iInd];   // Определяем WorkSheet  //если кол-во листов больше 1, иначе нет смысла искать //memoSheets - TMemo - с ключевыми фразами, напрмер, //Лист 1, Мой лист, Данные,   if WorkBk.Worksheets.Count>1 then begin     For x:=0 to memoSheets.Lines.Count-1 do begin      For q:=1 to WorkBk.Worksheets.Count do begin        WorkSheet:=WorkBk.WorkSheets.Get_Item(q) as _WorkSheet;        if WorkSheet.Name = memoSheets.Lines[x] then begin          //нашли лист          bNaydeno:=True;          WorkSheet.Activate(LOCALE_USER_DEFAULT);//активируем лист        end;        if bNaydeno= true then break;      end;      if bNaydeno=true then break;     end;//for   end else//if     WorkSheet:=WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;; ------------------ //Поиск последней строки... //можно заранее ставить в файле какую-нибудь метку, напрмер 99999 //функция Find будет показана ниже iNameRow,iLastRow: Integer sNameCol: String   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; memoNames - TMemo с наименованиями столбцов, т.к. в моем проекте у разных поставщиков //могут столбцы называться по-разному, например, Товар, Наименование, Наименование товара   //ищем наименование   For r:=0 to memoNames.Lines.Count-1 do begin     bNaydeno:=False;     if Find(memoNames.Lines[r],iNameRow,sNameCol,WorkSheet) then begin       ...      break;     end;//if Find(memoNames.Lines[r],iNameRow,sNameCol) then begin   end;//For r:=0 to memoNames.Lines.Count-1 do begin //так ищем все нужные столбцы, запоминая столбец в каждую отдельную переменную //начинаем импорт со строки iNameRow //в конце могут начаться пустые строки, если неправльно //определилась последняя незаполненная ячейка //тогда нужно прервать цикл импорта      if (WorkSheet.Cells.Item[iNameRow,sNameCol].Value='') or       (WorkSheet.Cells.Item[iNameRow,sNameCol].Value=' ') then       Inc(iStop)//если пустая строка, то увеличиваем на 1      else       iStop:=0;//если следующая не пустая то обнуляем и продолжаем импорт      //если начались пустые строки то прекращаем импорт      if iStop>4 then break; //sg1-TStringGrid      //наименование препарата      sg1.Cells[1,e]:=WorkSheet.Cells.Item[iNameRow,sNameCol].Value;      //цена      sg1.Cells[2,e]:=WorkSheet.Cells.Item[iNameRow,sPriceCol].Value; //DelProb функция удаления всего лишнего, кроме цифр, точек и запятых //навыходе получаем вместо "2 305 585,85" "2305585,85"      sg1.Cells[2,e]:=DelProb(sg1.Cells[2,e]);//удаляем пробелы      //производитель      sg1.Cells[3,e]:=WorkSheet.Cells.Item[iNameRow,sProdCol].Value;      Inc(iNameRow); //добавляем строки к StringGrid только если они нужны      if sg1.RowCount=e then sg1.RowCount:=sg1.RowCount+1;      //прерываем по желанию пользователя      if fmMain.vAbort=False then begin//прерываем операцию           ...        try         Ex1.Workbooks.Close(LOCALE_USER_DEFAULT);         Ex1.Disconnect;         Ex1.Quit;        except        end;//try-except        Exit;       end;//if fmMain.vAbort=False then begin //так закрываем Excel try   Ex1.Quit;   Ex1.Disconnect;  except   ShowMessage('Ошибка закрытия Excel'); //обнуляем переменную Range  VarClear(Range); Код sText - текст для поиска iRow - строка, в которой найдено значение sCol - колонка, в которой найдено значение UsedRange.Find - параметры для поиска, типа What:=sText, ищем в справке по Excel`ю 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 27.12.2004, 10:59

Зыкрыть Excel можно еще так, я так делаю при закрытии формы(окна) инморта Код  try   Ex1.Workbooks.Close(LOCALE_USER_DEFAULT);   Ex1.Disconnect;   Ex1.Quit;   Ex1:=nil;  except  end; на всякий случай дам функцию DelProb Код Function TfmImpExcel.DelProb(prob:string):string; Var i:integer; begin result:=''; For i:=1 to Length(prob) do begin   if (prob[i] in ['0'..'9']) or (prob[i]=',') or((prob[i]='.')) then result:=result+prob[i]; end; end;

Автор: Akella 27.12.2004, 12:03

Еще несколько примеров, используя Ole Excel:Variant - глобальная переменная Код ... begin //вначале проверяем, не открыт ли Excel  и закрываем if not VarIsEmpty(Excel) then begin  Excel.Quit;  Excel := Unassigned; end;//if    Try//открываем Excel и создаем раб.книгу      Excel:=CreateOleObject('Excel.Application');      /кол-во листов в новой книге      Excel.SheetsInNewWorkbook:=1;//      //добавляем раб.книгу      Excel.WorkBooks.Add;      //в переменную "загоняем" текущий лист      Sheets:=Excel.Workbooks[1].Sheets[1];    Except      SysUtils.beep;      ShowMessage('Не могу открыть Excel!');      Exit;    end;//try-except    //рисуем border //сначала определяем диапазон    Range:=Sheets.Range['B1'];    Range.Borders[4].LineStyle := 1;//Range.Borders[4] - можно ставить от 1 до 8 - точно не мпомню      //рисуем border вокруг ячейки (обрамление)      Range.Borders[1].LineStyle := 1;      Range.Borders[2].LineStyle := 1;      Range.Borders[3].LineStyle := 1;      Range.Borders[4].LineStyle := 1;    //присваиваем значение яцейке    Sheets.Cells[2,2]:=Edit1.Text;// формат Sheets.Cells[№ строки,№ колонки]    //так выполняем выравнивание в диапазоне    //присваиваем диапазону координаты ячейки    Range:=Sheets.Cells[2,2];//можно переменные Range:=Sheets.Cells[iRow,iCol];    Range.HorizontalAlignment := xlCenter;    Range.VerticalAlignment := xlCenter;    //форматируем шрифт    Sheets.Cells[iRow,3]:='ЗАЯВКА';    Range:=Sheets.Cells[iRow,3];    Range.Font.Bold:=True; //с присваиванием значения ячейке могут быть проблемы, т.к. Excel думает, что он очень умный //и вместо числа может переформатировать в дату вида 12дек2004, что бы такого не случилось, //можно заранее отформатировать ячейку в нужный формат (дата, число, валюта, текстовый) //все форматы можно узнать в Excel`е, с пом. макросов, просмотрев затем код, созданный самим //Excel`ем //#,##0.000$ - денежный //[$-FC19]dd mmmm yyyy г/;@ - дата //h:mm;@ - время //0.00% - проценты //# ??/?? - простые дроби 21/25 //[<=9999999]###-####;(###) ###-#### - номер телефона //@ - текстовый формат, если указывать такой формат и присваивать //числовое значение, а затем складывать, то ничего не выйдет //передаваемая строки из Delphi может отличаться, нужно эксперементировать tZay - TTable dbGridZay - DBGrid vRow - integer    while not tZay.Eof do begin      For iColCount:=0 to dbGridZay.Columns.Count-1 do begin        Range:=Sheets.Cells[vRow,iColCount+1];        Case tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).DataType of          ftFloat   : begin                        Range.NumberFormat := '0,000';                        Sheets.Cells[vRow,iColCount+1]:=                        tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsFloat                      end;          ftString  : begin                        Range.NumberFormat := '@';                        Sheets.Cells[vRow,iColCount+1]:=                        tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsString;                      end;          ftInteger : begin                        Range.NumberFormat := '0';                        Sheets.Cells[vRow,iColCount+1]:=                        tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsInteger;                      end;          ftAutoinc : begin                        Range.NumberFormat := '0';                        Sheets.Cells[vRow,iColCount+1]:=                        tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsInteger;                      end;          ftDate    : begin                        Range.NumberFormat := '@';                        dDate:=tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsDateTime;                        Sheets.Cells[vRow,iColCount+1]:=FormatDateTime('dd.mm.yyyy',dDate);                      end        else          Range.NumberFormat := '@';          Sheets.Cells[vRow,iColCount+1]:=          tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsString;        end;//case-else

Автор: Vit 27.12.2004, 18:57

Всем спасибо!

Автор: Akella 28.12.2004, 11:00

я не закончил удаляем лишние столбцы (по умолчанию со сдвигом влево) Код dbGridZay - DBGrid    For iColCount:= dbGridZay.Columns.Count-1 downto 0 do begin      if dbGridZay.Columns[iColCount].Visible=False then begin        UsedRange := Sheets.Range['A1','Z100'];//диапазон поиска заголовка        Range := UsedRange.Find(What:=dbGridZay.Columns[iColCount].title.Caption, LookIn := xlValues, LookAt := xlWhole,SearchDirection := xlNext);        if not VarIsEmpty(Range) then begin          try            FirstAddress := Range.Address;            s:=StringReplace(FirstAddress,'$','',[rfReplaceAll]);            [b]Range:=Sheets.Range[s+':'+Copy(s,1,1)+IntToStr(vRow)];[/b]            [b]Range.Delete;[/b]          except          end;//try        end;//if not VarIsEmpty(Range)then begin      end;//if dbGridZay.Columns[iColCount].Visible=False then begin    end;//for delete если будут какие-нибудь вопросы или поправки, с удовольствием рассмотрю, исправлю

Автор: Akella 5.1.2005, 10:35

запустить внешнее приложение и подождать, пока оно отработает такая функция тоже будет полезна Код function ExecAndWait(const FileName, Params: ShortString; const WinState: Word): boolean; export; var StartInfo: TStartupInfo; ProcInfo: TProcessInformation; CmdLine: ShortString; begin { Помещаем имя файла между кавычками, с соблюдением всех пробелов в именах Win9x } CmdLine := '"' + Filename + '" ' + Params; FillChar(StartInfo, SizeOf(StartInfo), #0); with StartInfo do begin   cb := SizeOf(StartInfo);   dwFlags := STARTF_USESHOWWINDOW;   wShowWindow := WinState; end; Result := CreateProcess(nil, PChar( String( CmdLine ) ), nil, nil, false,                         CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,                         PChar(ExtractFilePath(Filename)),StartInfo,ProcInfo); { Ожидаем завершения приложения } if Result then begin   WaitForSingleObject(ProcInfo.hProcess, INFINITE);   { Free the Handles }   CloseHandle(ProcInfo.hProcess);   CloseHandle(ProcInfo.hThread); end; end;

Автор: Alex 5.1.2005, 10:51

dsergey, http://vingrad.ru/VF-DLP-000765

Автор: Akella 5.1.2005, 11:12

вопросов больше не имею

Автор: tcomponent 13.1.2005, 15:39

в разделе мультимедии -> мегаплеер, валяются примеры id3(1.0-2.x)редкая штука надо вклычит в базу

Автор: Slawanix 18.1.2005, 23:00

Vit и всем привет! Vit, не знаю замечали дубликаты тем или нет, но на всякий случай скажу: дублируются темы: Ситемные функции и WinApi->Процессы, потоки...->Как увеличить процессорное время, выделяемое программе и тема оттуда же но Как поменять приоритет моего приложения. Поехали дальше. Нашел несколько темок по потокам(API & Delphi) Все взято с проекта DelphiWorld. №1 Как при создании объекта TThread передать ему некоторое значение Код К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл. Потомку надо передать имя файла, а вот как? Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим образом. В объект нити, происходящий от TThread дописывают поля. Как правило, в секцию PRIVATE. Затем переопределяют конструктор CREATE, который, принимая необходимые параметры заполняет соответствующие поля. А уже в методе EXECUTE легко можно пользоваться данными, переданными ей при его создании. TYourThread = class(TTHread)  private    FFileName: string;  protected    procedure Execute; overrided;  public    constructor Create(CreateSuspennded: Boolean; const AFileName: string); end; ... constructor TYourThread.Create(CreateSuspennded: Boolean;            const AFileName: string); begin  inherited Create(CreateSuspennded);  FFIleName := AFileName; end; procedure TYourThread.Execute; begin  try    ...    if FFileName = ...    ...  except    ...  end; end; ... TYourForm = class(TForm) ... private  YourThread: TYourThread;  procedure LaunchYourThread(const AFileName: string);  procedure YourTreadTerminate(Sender: TObject);  ... end; ... procedure TYourForm.LaunchYourThread(          const AFileName: string); begin  YourThread := TYourThread.Create(True, AFileName);  YourThread.Onterminate := YourTreadTerminate;  YourThread.Resume end; ... procedure TYourForm.YourTreadTerminate(Sender: TObject); begin  ... end; ... end. №2 Помещение формы в поток Код Delphi имеет в своем распоряжении классную функцию, позволяющую сделать это: procedure WriteComponentResFile(const FileName: string;  Instance: TComponent); Просто заполните имя файла, в котором вы хотите сохранить компонент, и читайте его затем следующей функцией: function ReadComponentResFile(const FileName: string;  Instance: TComponent): TComponent; №3 Несколько функций для TStream Код Оформил: DeeCo Автор: http://www.swissdelphicenter.ch { These are three utility functions to write strings to a TStream. Nothing fancy, but I just ended up coding this repeatedly so I made these functions. } { Hier sind einige TStreaam Hilfsfunktionen um strings in einen TStream zu schreiben. } unit ClassUtils; interface uses   SysUtils,   Classes; {: Write a string to the stream   @param Stream is the TStream to write to.   @param s is the string to write   @returns the number of bytes written. } function Writestring(_Stream: TStream; const _s: string): Integer; {: Write a string to the stream appending CRLF   @param Stream is the TStream to write to.   @param s is the string to write   @returns the number of bytes written. } function WritestringLn(_Stream: TStream; const _s: string): Integer; {: Write formatted data to the stream appending CRLF   @param Stream is the TStream to write to.   @param Format is a format string as used in sysutils.format   @param Args is an array of const as used in sysutils.format   @returns the number of bytes written. } function WriteFmtLn(_Stream: TStream; const _Format: string;   _Args: array of const): Integer; implementation function Writestring(_Stream: TStream; const _s: string): Integer; begin   Result := _Stream.Write(PChar(_s)^, Length(_s)); end; function WritestringLn(_Stream: TStream; const _s: string): Integer; begin   Result := Writestring(_Stream, _s);   Result := Result + Writestring(_Stream, #13#10); end; function WriteFmtLn(_Stream: TStream; const _Format: string;   _Args: array of const): Integer; begin   Result := WritestringLn(_Stream, Format(_Format, _Args)); end; Самих линков дать не могу, т.к. давно эту инфу отрыл, беру уже с винта Добавлено @ 23:02 Да, кстати, хочу заметить: это я не тестировал. Добавлено @ 23:08 Тоже с Delphi World Поток с доступом к глобальной переменной основной программы Код Автор: Xavier Pacheco unit Main; interface uses  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  StdCtrls; type  TMainForm = class(TForm)    Button1: TButton;    procedure Button1Click(Sender: TObject);  private    { Private declarations }  public    { Public declarations }  end; var  MainForm: TMainForm; implementation {$R *.DFM} { NOTE: Change GlobalStr from var to threadvar to see difference } var  //threadvar  GlobalStr: string; type  TTLSThread = class(TThread)  private    FNewStr: string;  protected    procedure Execute; override;  public    constructor Create(const ANewStr: string);  end; procedure SetShowStr(const S: string); begin  if S = '' then    MessageBox(0, PChar(GlobalStr), 'The string is...', MB_OK)  else    GlobalStr := S; end; constructor TTLSThread.Create(const ANewStr: string); begin  FNewStr := ANewStr;  inherited Create(False); end; procedure TTLSThread.Execute; begin  FreeOnTerminate := True;  SetShowStr(FNewStr);  SetShowStr(''); end; procedure TMainForm.Button1Click(Sender: TObject); begin  SetShowStr('Hello world');  SetShowStr('');  TTLSThread.Create('Dilbert');  Sleep(100);  SetShowStr(''); end; end.

Автор: Slawanix 18.1.2005, 23:12

Цитата(Slawanix @ 19.1.2005, 00:00) Vit, не знаю замечали дубликаты тем или нет, но на всякий случай скажу: дублируются темы: Ситемные функции и WinApi->Процессы, потоки...->Как увеличить процессорное время, выделяемое программе и тема оттуда же но Как поменять приоритет моего приложения. Имеется ввиду DRKB

Автор: Akella 19.1.2005, 11:15

Продолжаю тему об MS Excel. Код //Объединение ячеек Sheet.Range[...].Merge(Across) ------------------------------------------------------- Относительно LOCALE_USER_DEFAULT Теоретически, в MSDN написано: "Indicates that the parameter is a locale ID (LCID)". Одни (Чарльз Калверт) предлагают в качестве его использовать 0, как идентификатор языка по умолчанию, другие - результат функции GetUserDefaultLCID. В некоторых случаях, чаще в связке Windows 2000 + Excel 2000, оба решения не проходят. Причем, выдается сообщение о попытке "использовать библиотеку старого формата..." Поэтому, рекомендуем в качестве lcid использовать значение константы LOCALE_USER_DEFAULT. --------------------------------------------------------------------------------- Относительно открытия существующих рабочих книг Вот как описан метод Open в импортированной библиотеке типов: function Open(const Filename: WideString; UpdateLinks: OleVariant; ReadOnly: OleVariant; Format: OleVariant; Password: OleVariant; WriteResPassword: OleVariant; IgnoreReadOnlyRecommended: OleVariant; Origin: OleVariant; Delimiter: OleVariant; Editable: OleVariant; Notify: OleVariant; Converter: OleVariant; AddToMru: OleVariant; lcid: Integer): Workbook; safecall; Что вам из всего этого может понадобиться: · FileName Имя открываемого файла, желательно с полным путем, иначе Excel будет искать этот файл в каталоге по умолчанию; · AddToMru True - если необходимо запомнить файл в списке последних открытых файлов; · IgnoreReadOnlyRecommended Если файл рекомендован только для чтения, то при открытии Excel выдает соответствующее предупреждение. Чтобы его игнорировать, передайте в качестве данного параметра True. Используя позднее связывание При позднем связывании не нужно указывать все дополнительные параметры или LCID, можно просто написать вот так: var Workbook: OLEVariant; ... Workbook := Excel.WorkBooks.Open('C:\Test.xls'); Примечание: Если вы хотите получше узнать метод Open, например, как с его помощью открывать файлы текстовых форматов с разделителями, воспользуйтесь "пишущим" плеером VBA. Запишите макросы, а затем поправьте их по необходимости. Создание новой книги Используя раннее связывание var IWorkbook: Excel8_TLB._Workbook; ... IWorkbook := IExcel.Workbooks.Add(EmptyParam, xlLCID); Передача в качестве первого параметра EmptyParam означает, что будет создана новая книга с количеством пустых листов, выставленным по умолчанию. Если в первом параметре вы передадите имя файла (с полным путем, иначе поиск осуществляется в каталоге по умолчанию), этот файл будет использован как шаблон для новой книги. Вы можете также передать одну из следующих констант: xlWBATChart, xlWBATExcel4IntlMacroSheet, xlWBATExcel4MacroSheet, или xlWBATWorksheet. В результате будет создана новая книга с единственным листом указанного типа. Внимание - важно! Excel не может держать открытыми несколько книг с одинаковыми названиями, даже если они лежат в разных каталогах, поэтому при создании файла по шаблону добавляет к имени файла новой книги номер (шаблон "test.xls" - новый файл "test1.xls"). ---------------------------------- Закрытие книги Используя раннее связывание var SaveChanges: boolean; ... SaveChanges := True; IWorkbook.Close(SaveChanges, EmptyParam, EmptyParam, xlLCID); Если в качестве параметра SaveChanges вы передадите EmptyParam, Excel задаст вопрос, сохранять ли рабочую книгу. Второй параметр позволяет вам определить имя файла, а третий указывает, нужно ли отправлять книгу следующему получателю. Используя позднее связывание При позднем связывании нет необходимости указывать дополнительные параметры, поэтому вы можете просто написать: Workbook.Close(SaveChanges := True); или Workbook.Close; ------------------------------------------------------------- Как передать абсолютный адрес ячейки? Нужно использовать символ $ - Лист1!$A$1:$D$3' ------------------------------------------------------------- Так можно добавить новый модуль: var IModule: VBIDE8_TLB.VBComponent; //с эти нужно поэксперементировать ... IModule := IWorkbook.VBProject.VBComponents.Add( TOLEEnum(VBIDE8_TLB.vbext_ct_StdModule) ); IModule.Name :='MyModule1'; ,поместить в него новую процедуру VBA: IModule.CodeModule.AddFromString('PUBLIC SUB MySub1()'#13'Msgbox "Hello, World!"'#13'End sub'#13); и запустить эту процедуру OLEVariant(Excel).Run('MyModule1.MySub1'); ----------------------------------------------------------- Различные способы обращения к ячейкам Var Value:Variant; ... try //различные способы Value := ISheet.Cells.Item[2, 1].Value; Value := ISheet.Range['A2', EmptyParam].Value; Value := ISheet.Range['TestCell', EmptyParam].Value; Value := IWorkbook.Names.Item('TestCell', EmptyParam, EmptyParam).RefersToRange.Value; finally ISheet := nil; end; ----------------------------------------------------------- Копирование данных в буфер обмена var ISheetSrc, ISheetDst: Worksheet;//в разных версиях IRangeSrc, IRangeDst: Range; //могут объявляться по разному ... IRangeSrc.Copy(IRangeDst); Метод Copy интерфейса Range принимает в качестве параметра любой другой Range, совпадение размеров источника и получателя необязательно. При копировании области убедитесь, что не редактируете ячейку, иначе возникнет исключение "Call was rejected by callee". Использование метода Copy без указания параметра destination скопирует ячейки в буфер обмена.

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