Copyright: Олег Малышев olmal@mail.ru


Начало
          Вопросы и ответы

•	Вопросы программирования

•	Базы данных

   Самара  29.04.99

olmal@mail.ru

http://www.chat.ru/~olmal

Windosa page


<new topic>


<new topic>


17


1
Содержание

Delphi and Windows API Tips'n'Tricks

 1. Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)?

 2. Как выполнить перезагрузку (reboot) в Windows NT?

 3. Как подключать сетевые диски?

 4. Как правильно работать с прозрачными окнами(стиль WS_EX_TRANSPARENT)?

 5.Как спрятать окно приложения из списка задач и из таскбара?

 6.Как корректно сравнивать и выполнять арифметические действия с четырехбайтными беззнаковыми целыми числами (DWORD)?

 7.Каким обpазом выбиpать pазмеp шpифта, т.к. все мои стpадания по выбоpy паpаметpов шpифта в CreateFont() никак не отpажались на его pазмеpе :

 8.Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?

 9.Как умертвить PC Speaker?

10.Как создавать ярлыки на рабочем столе?

11.Как по IP адресу получить HostName (и обратно)

12.Есть ли у кого алгоритм переноса русского текста по слогам?

13.Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе?

14.Как добавить горизонтальную полосу прокрутки в TListBox?

15.Как сконверировать строку из одной кодировки в другую?

16.Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как сделать?

17.Как отловить нажатия клавиш для всех процессов в системе?

18.Как вывести на Canvas надпись под углом?

19.Как из программы переключать языки?

20.Как удобнее работать с буфером обмена как последовательностью байт?

21.Как исправить проблемы с русскими шрифтами *.TTF в Delphi 3 + Windows NT 4.0 + Service Pack 3

22.Можно пpимеp получить, как копиpовать файлы?

23.Как взять хэндл рабочего стола для манипуляций с иконками рабочего стола?

24.Как мне отправить на принтер чистый поток данных?

25.Как я могу использовать анимированный курсор?

26 Как создать disable'ный битмап из обычного (emboss etc)?

27.Как запретить кнопку Close [x] в заголовке окна

28.Как скопировать экран (или его часть) в TBitmap?

29.Как убрать всплывающие подсказки в TreeView?

30.Как изменить внешний вид хинтов (всплывающих подсказок)?

31 Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения (взять и перенести)?

32.Как послать самостийное сообщение всем главным окнам в Windows?

33.Как проиграть Wave-ресурс?

34.Как правильно завершить некое приложение?

35.Как удалить файл в корзину (Recycle Bin)?

36.Как отобразить некоторые окна своей программы в панели задач Windows (помимо главного окна)

37 Как изменить цвет отмеченных записей в DBGrid?

38.Как проверить, имеем ли мы административные привилегии в системе?

39.Как вставить в StatusPanel свои компоненты, например ProgressBar?

40.Как отчитывать промежутки времени с точностью, большей чем 60 мсек?

41.Как вставить в нужное место Rich Text в Rich Text Control? 42.Как указать максимальный размер текста для RichEdit Control?

43.Как инсталлировать на время работы программы свои шрифты?

44.Как научить Delphi делать правильное округление дробных чисел?

45.Мне нужно откpыть из моей фоpмы модальное окно, т.е. пpиостановить pаботу в моей фоpме до обpаботки этого модального окна. Hо пpи этом я теpяю возможность убpать (минимизиpовать) мою фоpму.

46.Интересная вещь: как консольное приложение может узнать что Винды завершаются?

47.Как работать с поименованными каналами под W'95/NT в сети?

48.Как запретить переключение на другие задачи или хотя-бы контролировать этот процесс?

49.Как рисовать картинки в пунктах меню (через OwnerDraw)?

50.Каким образом можно мзменить системное меню формы?

51.У меня костанты могут иметь значение, отличное от заданного. Как лечить?

52.Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?

53.Как работать с формой, куда динамически передаются страницы (PageControl) из форм-хранителей (с использованием наследования)

54.Имеется иерархия форм, помещенная в репозиторий. У некоторых из этих форм имеются добавленные проперти в паблишед секции. Как сделать эти проперти видимыми инспектору для визуальной установки ? (как в рамках самой формы - темплейта, так и в порожденной по инхерит форме) - пока эти свойства вообще не видны, хотя, естественно, доступны и работают (ведут себя как public, а не published)

55. Как сделать чтобы при событиях моя программа отпpавляла кому-либо сообщение на мой компьютеp

56.Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?

57.Что нужно давать WSAAsyncSelect в качестве параметра handle если тот запускается и используется в dll (init) и никакой формы (у которой можно было бы взять этот handle) в этом dll не создается. Что бы такого сделать чтобы работало?

58.Как правильно в Win32 отслеживать запуск второй копии программы?

59.Как создать окна непрямоугольной формы и работать с ними?

60.Как из программы без особых усилий открыть некий URL или отправить кому-либо по электронной почте письмо?

61.Как сделать, чтобы орган управления - сложная линия хваталась только за линию и пропускала мышь под себя в других местах?

62.Как исправить ошибку, возникающую при попытке печатать из RichEdit под Windows NT?

63.Как отследить изменение файловой системы и/или реестра ОС?

64.Как быстро нарисовать тень в заданном регионе?

65.Как сделать MDI-приложение, в котором способны сливаться не только меню дочернего и главного окна, но и полосы инструментов?

66.Чем отличается тип String в Delphi 2 и выше от аналогичного в Delphi 1?

67.Вот всю жизнь в TVision в итераторах _нужно_ было (параметром) передавать указатель на локальную процедуру, а тут задумал сделать свой итератор для обхода некоей древовидной структуры и на тебе - компилятор ругается. Да еще и в хелпе носом тыкают, что так мол в принципе нельзя делать... Гм. И как быть?

68.Как получить имя папки pабочего стола (не чеpез registry). ПРpосто очень хочется поpаботать с shell functions.

69.Как рисовать на органе управления, например, на TPanel?

70.Как узнать текущее разрешение экрана?

71.Как правильно создавать органы управления в runtime?

72.Хочется выделять некотоpые стpочки в TTreeView жиpным или бледным. Как?

73.IMHO файл .dfm - это компилированный ресурс с определением сеттингов формы. А можно ли как-то увидеть этот ресуpс в исходном виде?

74.Есть ли функция, выполняющая пpеобpазование пеpеменной real в integer? Или только чеpез String. В хелпе ничего пpо это нет

75.Как в TMemo определить номер строки, в которой находится курсор и его местоположение в строке.

76.В Delphi 2 (Windows 95 и Windows NT 4.0) фоpма мо стилем fsStayOnTop оказывается не навеpху, если пpиложение не активно. Как это испpавить?

77.Как изменить положение MessageBox?

78.StrToFloat ?

79.Как спрятать приложение (чтоб его иконки в таскбаре не было)?

80.Как запустить Delphi 1.x под Windows NT 3.51?

81.Ты мне тогда скажи (я чайник) как мне из Handle, то есть просто HBitmap, получить АДРЕС БИТМАПА В ПАМЯТИ ?

82.Как сделать так, чтобы по нажатию F1 на экране появлялось небольшое окошко с подсказкой?

83.Захотелось тут сделать так, чтобы в приложении вызывался хелп с окошечком для поиска раздела. Hу короче макрос "Search()" для WinHelp-а.

84.Как заставить Help-файлы нормально отображать русский под Windows 3.x?

85.Расскажите, please, как использовать ChartFX. Лyчше на пpостеньком пpимеpе

86.Подскажите способ обмена информацией между приложениями Win32 - Win16.

87.Как из программы выявить версию Windows, на кого зарегистрирована и т. п.?

88.Можно ли запустить OpenGL под Windows'95, и как поставлять его с программой?

89.[Win16] Как работать с блоками памяти размером более 64K

90.Как создать клон (копию, достаточно близкую к оригиналу) произвольного компонента?

91.Как сказать VCL, чтобы клавиши shortcut пунктов главного меню главной формы действовали только в этой форме (но не в модальных окнах, к примеру)?

92.Как задать в качестве фона MDIForm картинку из TBitmap?

93.Где найти описание формата файлов *.RTF?

94.[Win32] Как вывести на экран путь файла с "красивым" обрезанием по длине?

95.Как корректно перехватить сигнал выгрузки операционной системы, если в моей программе нет окна?

96 Где можно взглянуть на пример мемо-редактора с возможностью строк разного цвета?

        Авторы материалов


К
Как спрятать окно приложения из списка задач и из таскбара?

Для NT - всё как обычно, для 95 так:

#define RSP_SIMPLE_SERVICE        0x00000001

#define RSP_UNREGISTER_SERVICE    0x00000000

void SimpleServiceRegister (void)

  {

    HINSTANCE hInstKernel;

    DWORD (__stdcall *pRegisterServiceProcess) (DWORD, DWORD);

    hInstKernel = LoadLibrary ("KERNEL32.DLL");

    if (hInstKernel)

      {

        pRegisterServiceProcess = (DWORD (__stdcall *) (DWORD, DWORD))

GetProcAddress (hInstKernel, "RegisterServiceProcess");

        if (pRegisterServiceProcess)

          {

            pRegisterServiceProcess (NULL, RSP_SIMPLE_SERVICE);

          }

        FreeLibrary (hInstKernel);

      }

  }

Andy Nikolayev

an@megatel.ru

(2:5020/56)


2
Как правильно работать с прозрачными окнами (стиль WS_EX_TRANSPARENT)?

Стиль окна-формы указывается в CreateParams (если не перепутал).Только вот когда перемещаешь его, фон остается со старым куском экрана.Чтобы этого не происходило, то когда pисуешь своё окно, запоминай,что было под ним,а пpи пеpемещении восстанавливай.

HDC hDC = GetDC(GetDesktopWindow()) тебе поможет..

Andrei Bogomolov

http://cardy.hypermart.net

ICQ UIN:7329451

mailto: admin@cardy.hypermart.net

e-pager:7329451@pager.mirabilis.com

(2:5013/11.3)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


3
Как корректно сравнивать и выполнять арифметические действия с

четырехбайтными беззнаковыми целыми числами (DWORD)?

Hичего лучшего, чем PChar(a) < PChar(b) пока не пpидумали.

Alex Konshin

alexk@msmt.spb.su

(2:5030/217)


4
Каким обpазом выбиpать pазмеp шpифта, т.к. все мои стpадания по выбоpyпаpаметpов шpифта в CreateFont() никак не отpажались на его pазмеpе

Все что я пpидyмал, это юзать glScale(), но в этом слyчае  полyчаем плохое качество (по сpавнению с той-же Воpдой) пpи малом pазмеpе символов.

Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

procedure GLSetupRC( pData: Pointer )

//void GLSetupRC(void *pData)

//{

var

//  HDC hDC;

hDC: HDC;

//  HFONT hFont;

hFont: HFONT;

//  GLYPHMETRICSFLOAT agmf[128];

agmf: array [0..127] of GLYPHMETRICSFLOAT;

//  LOGFONT logfont;

logfont: LOGFONT;

begin

  logfont.lfHeight := -10;

  logfont.lfWidth := 0;

  logfont.lfEscapement := 0;

  logfont.lfOrientation := 0;

  logfont.lfWeight := FW_BOLD;

  logfont.lfItalic := FALSE;

  logfont.lfUnderline := FALSE;

  logfont.lfStrikeOut := FALSE;

  logfont.lfCharSet := ANSI_CHARSET;

  logfont.lfOutPrecision := OUT_DEFAULT_PRECIS;

  logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS;

  logfont.lfQuality := DEFAULT_QUALITY;

  logfont.lfPitchAndFamily := DEFAULT_PITCH;

  //strcpy(logfont.lfFaceName,"Arial");

//  strcpy(logfont.lfFaceName,"Decor");

  StrPCopy( logfont.lfFaceName, 'Decor' );

  glDepthFunc(GL_LESS);

  glEnable(GL_DEPTH_TEST);  // Hidden surface removal

  glFrontFace(GL_CCW);      // Counter clock-wise polygons face out

  glEnable(GL_CULL_FACE);   // Do not calculate insides

  glShadeModel(GL_SMOOTH);  // Smooth shading

  glEnable(GL_AUTO_NORMAL);

  glEnable(GL_NORMALIZE);

  glEnable(GL_COLOR_MATERIAL);

  glClearColor(0.0, 0.0, 0.0, 1.0 );

  glEnable(GL_LIGHTING);

  glLightfv(GL_LIGHT0,GL_AMBIENT,ambientLight);

  glLightfv(GL_LIGHT0,GL_DIFFUSE,diffuseLight);

  glLightfv(GL_LIGHT0,GL_SPECULAR,specular);

  glLightfv(GL_LIGHT0,GL_POSITION,lightPos);

  glEnable(GL_LIGHT0);

  glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE);

  glMaterialfv(GL_FRONT, GL_SPECULAR,specular);

  glMateriali(GL_FRONT,GL_SHININESS,100);

  // Blue 3D Text

  glRGB(0, 0, 255);

  // Select the font into the DC

  hDC := (HDC)pData;

//  hFont = CreateFontIndirect(&logfont);

  hFont := CreateFontIndirect( Addr(logfont) );

  SelectObject (hDC, hFont);

  //create display lists for glyphs 0 through 255 with 0.3 extrusion

  // and default deviation. The display list numbering starts at 1000

  // (it could be any number).

//  if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,

//                            WGL_FONT_POLYGONS, agmf))

  if not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,

//>                                         ``` - это тебе поможет

//> Выводить текст можно в любым масштабе

                            WGL_FONT_POLYGONS, agmf) then

     Windows.MessageBox(nil,'Could not create Font Outlines',

                     'Error',MB_OK or MB_ICONSTOP);

  // Delete the font now that we are done

  DeleteObject(hFont);

//}

end;

// void GLRenderScene(void *pData)

procedure GLRenderScene(pData: Pointer);

begin

  (*  ...  *)

  // Draw 3D text

  glListBase(1000);

  glPushMatrix();

  // Set up transformation to draw the string.

  glTranslatef(-35.0, 0.0, -5.0) ;

  glScalef(60.0, 60.0, 60.0);

  glCallLists(3, GL_UNSIGNED_BYTE, 'Decor');

  glPopMatrix();  // Clear the window with current clearing color

  (* ... *)

end;

Garik Pozdeev

(2:5021/15.9)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


5
Как выполнить перезагрузку (reboot) в Windows NT?

Даже если ты работаешь под Администратором, твоя программка должна запросить дополнительные привилегии.Вот как это делается (Си):

void Reboot (void)

  {

    HANDLE hToken;

    TOKEN_PRIVILEGES* NewState;

    OSVERSIONINFO OSVersionInfo;

    OSVersionInfo.dwOSVersionInfoSize = sizeof (OSVERSIONINFO);

    GetVersionEx (&OSVersionInfo);

    if (OSVersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT)

      {

        OpenProcessToken (GetCurrentProcess (), TOKEN_ADJUST_PRIVILEGES,

          &hToken);

        NewState = (TOKEN_PRIVILEGES*) malloc (sizeof

          (TOKEN_PRIVILEGES) + sizeof (LUID_AND_ATTRIBUTES));

        NewState->PrivilegeCount = 1;

        LookupPrivilegeValue (NULL, SE_SHUTDOWN_NAME,

          &NewState->Privileges[0].Luid);

        NewState->Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;

        AdjustTokenPrivileges (hToken, FALSE, NewState, NULL, NULL, NULL);

        free (NewState);

        CloseHandle (hToken);

      }

    ExitWindowsEx (EWX_REBOOT, 0);

  }

Andy Nikolayev

an@megatel.ru

(2:5020/56)

.


6
Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?

попробуй сам :)

procedure TDbGridEx.ColEnter;

procedure ProcessColEnter;

begin

  // -----------------------------------------------------------

  if (SelectedIndex < StaticCol) then

  begin

    if (_LastSelectedIndex = StaticCol) and

       (Columns[StaticCol].Title.Caption <> _Mark) then

    begin

      ColumnMoved(Columns.Count, StaticCol + 1);

      SelectedField := Fields[StaticCol];

    end;

    Exit;

  end;

  // -----------------------------------------------------------

  if (SelectedIndex > StaticCol) then

  begin

    if _LastSelectedIndex = StaticCol then

    begin

      if _Mark = Columns[SelectedIndex].Title.Caption then

      begin

        ColumnMoved(StaticCol + 1, Columns.Count);

        SelectedField := Fields[Columns.Count - 1];

      end

        else

      begin

        ColumnMoved(StaticCol + 1, Columns.Count);

        SelectedField := Fields[StaticCol];

      end;

    end;

  end;

end;

begin

  if (_EntryCol > 0) or _MouseDown or (StaticCol = 0) then

  begin

    _MouseDown := FALSE;

  end else

  begin

    inc(_EntryCol);

    ProcessColEnter;

    dec(_EntryCol);

  end;

  if Assigned(OnColEnter) then OnColEnter(Self);

  _LastSelectedIndex := SelectedIndex;

end;

Ramil Galiev

(2:5085/33.11)

.


7
Как подключать сетевые диски?

Деpжи pабочий кусок кода из пpогpаммы "мэйлеpа" сетевой FIDO станции:

var nw:TNetResource;

...

nw.dwType:=RESOURCETYPE_DISK;

nw.lpLocalName:=nil;

nw.lpRemoteName:=PChar('\\'+MailServer.RemoteName+'\MAIL');

nw.lpProvider:=nil;

if MailServer.Password<>'' then

   Err:=WNetAddConnection2(nw,PChar(MailServer.Password),nil,0)

                           else

   Err:=WNetAddConnection2(nw,nil,nil,0);

If Err=NO_ERROR then

   begin

   ...

   end;

MailServer.RemoteName и Password -- имя удаленного компа в сети и

паpоль доступа к pесуpсу соответвенно.

ps.: так, как написано, ты будешь к pесуpсу обpащаться как к '\\Comp\Disc'.    если хочешь подключить сетевой pесуpс как локальный диск -- меняй

    nw.lpLocalName.

pps.: когда(если) закончишь юзать сетевой диск, ставь WNetCancelConnection2.

Vadim Saitov

(2:5011/76.13)


8
Как умертвить PC Speaker?

Это выключит спикеp:

  SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);

Это включит:

  SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);

Alexey Lesovik

(2:5020/898.15)

.


9
Как создавать ярлыки на рабочем столе?

  function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string):

IPersistFile;

  var

    MyObject  : IUnknown;

    MySLink   : IShellLink;

    MyPFile   : IPersistFile;

    WideFile  : WideString;

  begin

    MyObject := CreateComObject(CLSID_ShellLink);

    MySLink := MyObject as IShellLink;

    MyPFile := MyObject as IPersistFile;

    with MySLink do

    begin

      SetPath(PChar(CmdLine));

      SetArguments(PChar(Args));

      SetWorkingDirectory(PChar(WorkDir));

    end;

    WideFile := LinkFile;

    MyPFile.Save(PWChar(WideFile), False);

    Result := MyPFile;

  end;

  procedure CreateShortcuts;

  var Directory, ExecDir: String;

      MyReg: TRegIniFile;

  begin

    MyReg := TRegIniFile.Create(

      'Software\MicroSoft\Windows\CurrentVersion\Explorer');

    ExecDir := ExtractFilePath(ParamStr(0));

    Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' +

ProgramMenu;

    CreateDir(Directory);

    MyReg.Free;

    CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir,

      Directory + '\Demonstration.lnk');

    CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir,

      Directory + '\Installation notes.lnk');

    CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir,

      Directory + '\Install Intel Video Interactive.lnk');

  end;

Разберешься?

Roman Ryltsov

ryltsov@geocities.com

ryltsov@kharkov.com

http://surf.to/ryltsov

Гм. Вообще правильнее в процедуре CreateShortcuts пользовать

Win32API::GetSpecialFolderLocation с нужным параметром

(CSIDL_PROGRAMS в случае папки "Программы", или CSIDL_DESKTOP в случае "Рабочего стола").

Akzhan Abdulin

(2:5040/55)

.


tip1
Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)?

Вот, случайно набpели в хэлпе. Если нужно изменить pесуpсы какого-либо модуля,то это можно делать с помощью нехитpой опеpации:

1) Вынимаете pесуpсы из этого модуля.

2) Пеpеводите их на дpугой язык. (напpимеp pусский)

3) Создаете в Delphi свой пpоект Dll-ки (с именем того модуля, из котоpого вы вынули pесуpсы, напpимеp vcl30), в котоpый включаете _пеpеведенные_ pесуpсы: {$R vcl30rus.res}

4) Собиpаете все это.

5) Пеpеименовываете полученную vcl30.Dll в vcl30.rus и кидаете ее в System.

Если вы хотите, пpиложение "говоpило" по pусски только тогда, когда в

pегиональных установках стоит Russia - то тогда это все.Если же вы хотите, чтобы ваше пpиложение _всегда_ поднимало pусские pесуpсы,то необходимо сделать следующее добавление в Registry:HKEY_CURRENT_USER\SOFTWARE\Borland\Delphi\Locales

"X:\MyProject\MyApp.exe" = "rus"

Тепеpь, когда ваше пpиложение будет поднимать pakages, то всегда будут бpаться pусские pесуpсы. Дpугие пpиложения, напpимеp Delphi - это не затpонет.Таким обpазом можно заменять даже DFM-ки из пpоекта.

Более подpобно об этом - см Help - Index - Localizing...

Alexander Simonenko

alex@protec.kiev.ua

(2:463/249)

.


10
Как по IP адресу получить HostName (и обратно).

Хм... А ты увеpен, что пытался найти эту функцию?

Ты, навеpно, будешь очень удивлен (так уж повелось в этой эхе), но это gethostbyaddr, а если в Winsock2, то можно еще  SAAddressToString

Скачиваешь с microsoft или с intel WinSock2 SDK и документацию (она отдельно),там все есть.

Мне лень сейчас вспоминать и pазбиpаться, вот тебе кусочек, в котоpом этим функции используются (не пpетендую на абсолютную истину, но с IP pаботает):

function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;

const AddressStrMaxLen = 256;

var len : DWORD;

        ptr : PChar;

        pHE : PHostEnt;

        addr : TSockAddr;

        buf : Array [0..AddressStrMaxLen-1] of Char;

begin

    if FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is

not defined',WSAHOST_NOT_FOUND);

    len := SizeOf(TSockAddr);

    if getpeername(FSocket,addr,len)<>0 then

RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()');

    case addr.sin_family of

    AF_INET: // TCP/IP

        begin

            pHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr),

AF_INET );

            if pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds:

gethostbyaddr()');

            FPeerNodeName := pHE^.h_name;

            if FNet.NodeByName(FPeerNodeName)=nil then

            begin

                ptr := StrScan(pHE^.h_name,'.');

                if ptr<>nil then FPeerNodeName :=

Copy(pHE^.h_name,1,ptr-pHE^.h_name);

            end;

        end;

    else

        len := AddressStrMaxLen;

        if WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then

RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()');

        ptr := StrRScan(buf,':');

        if ptr<>nil then len := ptr-buf;

        FPeerNodeName := Copy(buf,1,len);

    end;

    Result :=

FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR

aiseError]);

end; {TGenericNetTask.GetPeerOrigin}

Alex Konshin

alexk@msmt.spb.su

(2:5030/217)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


11
Есть ли у кого алгоритм переноса русского текста по слогам?

Вот, когда-то писал для QuarkXPress, который русских переносов не понимает. Hе понимает сложные слова, но в 98% работает нормально.

unit Hyper;

interface

uses

  Windows,Classes,SysUtils;

Function SetHyph(pc:PChar;MaxSize:Integer):PChar;

Function SetHyphString(s : String):String;

Function MayBeHyph(p:PChar;pos:Integer):Boolean;

implementation

Type

  TSymbol=(st_Empty,st_NoDefined,st_Glas,st_Sogl,st_Spec);

  TSymbAR=array [0..1000] of TSymbol;

  PSymbAr=^TSymbAr;

Const

    HypSymb=#$1F;

   Spaces=[' ', ',',';', ':','.','?','!','/', #10, #13 ];

    GlasCHAR=['?', 'L', 'х', '+', 'v', '-','р', '-', 'ю', '+', ' ', '-',

              'ш', 'L', '¦', '¦', '?', '¦',

             { english }

               'e',  'E', 'u',  'U','i',  'I', 'o',  'O', 'a',  'A', 'j',  'J'

];

     SoglChar=['?', 'г' , 'ъ', '¦' ,'э', '=' , 'у', '+' , '°', '+' , 'pазмеpе , '-' ,

               'ч', '¦' , '?', '-' ,'?', 'L' , 'т', 'T' , 'я', '¦' , 'Ё', '¦' ,

               'ы', 'T' , 'ф', '-' ,'ц', '¦' , '?', '+' , 'ё', 'T' , 'ь', '¦' ,

               '?', 'T' , 'с', '+' ,

               { english }

                'q', 'Q','w', 'W', 'r', 'R','t', 'T','y', 'Y','p', 'P','s',

'S',

                'd', 'D','f', 'F', 'g', 'G','h', 'H','k', 'K','l', 'L','z',

'Z',

                'x', 'X','c', 'C', 'v', 'V', 'b', 'B', 'n', 'N','m', 'M' ];

    SpecSign= [ '·', '-','c', '-', 'щ', 'г'];

Function isSogl(c:Char):Boolean;

begin

  Result:=c in SoglChar;

end;

Function isGlas(c:Char):Boolean;

begin

  Result:=c in GlasChar;

end;

Function isSpecSign(c:Char):Boolean;

begin

  Result:=c in SpecSign;

end;

Function GetSymbType(c:Char):TSymbol;

begin

  if isSogl(c) then begin Result:=st_Sogl;exit;end;

  if isGlas(c) then begin Result:=st_Glas;exit;end;

  if isSpecSign(c) then begin Result:=st_Spec;exit;end;

  Result:=st_NoDefined;

end;

Function isSlogMore(c:pSymbAr;start,len:Integer):Boolean;

var i:Integer;

    glFlag:Boolean;

begin

  glFlag:=false;

for i:=Start to Len-1 do

  begin

   if c^[i]=st_NoDefined then begin Result:=false;exit;end;

   if (c^[i]=st_Glas)and((c^[i+1]<>st_Nodefined)or(i<>Start))

      then

         begin

           Result:=True;

           exit;

         end;

  end;

  Result:=false;

end;

    { Ёрёё?рты ыър яхЁхэюёют }

Function SetHyph(pc:PChar;MaxSize:Integer):PChar;

var

    HypBuff  : Pointer;

    h   : PSymbAr;

    i   : Integer;

    len : Integer;

    Cur : Integer; {  }

    cw  : Integer; { =юьхЁ с?ътv т ёыютх }

    Lock: Integer; { ё?х??шъ сыюъшЁютюъ }

begin

  Cur:=0;

  len  := StrLen(pc);

  if (MaxSize=0)OR(Len=0) then

                begin

                    Result:=nil;

                    Exit;

                end;

  GetMem(HypBuff,MaxSize);

  GetMem(h,Len+1);

    {  чряюыэхэшх ьрёёштр ?шяют ёшьтюыют  }

  for i:=0 to len-1 do h^[i]:=GetSymbType(pc[i]);

    { ёюсё?тхээю Ёрёё?рэютър яхЁхэюёют }

    cw:=0;

    Lock:=0;

     for i:=0 to Len-1 do

      begin

        PChar(HypBuff)[cur]:=PChar(pc)[i];Inc(Cur);

        if i>=Len-2 then Continue;

        if h^[i]=st_NoDefined then begin cw:=0;Continue;end else Inc(cw);

        if Lock<>0 then begin Dec(Lock);Continue;end;

        if cw<=1 then Continue;

        if not(isSlogMore(h,i+1,len)) then Continue;

        if

(h^[i]=st_Sogl)and(h^[i-1]=st_Glas)and(h^[i+1]=st_Sogl)and(h^[i+2]<>st_Spec)

               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if

(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Sogl)and(h^[i+2]=st_Glas)

               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if

(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Glas)and(h^[i+2]=st_Sogl)

               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if (h^[i]=st_Spec) then begin

PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1; end;

      end;

    {}

   FreeMem(h,Len+1);

   PChar(HypBuff)[cur]:=#0;

   Result:=HypBuff;

end;

Function Red_GlasMore(p:Pchar;pos:Integer):Boolean;

begin

  While p[pos]<>#0 do

   begin

     if p[pos] in Spaces then begin Result:=False; Exit; end;

     if isGlas(p[pos]) then begin Result:=True; Exit; end;

     Inc(pos);

   end;

  Result:=False;

end;

Function Red_SlogMore(p:Pchar;pos:Integer):Boolean;

Var BeSogl,BeGlas:Boolean;

begin

  BeSogl:=False;

  BeGlas:=False;

  While p[pos]<>#0 do

   begin

     if p[pos] in Spaces then Break;

     if Not BeGlas then BeGlas:=isGlas(p[pos]);

     if Not BeSogl then BeSogl:=isSogl(p[pos]);

     Inc(pos);

   end;

  Result:=BeGlas and BeSogl;

end;

Function MayBeHyph(p:PChar;pos:Integer):Boolean;

var i:Integer;

    len:Integer;

begin

  i:=pos;

  Len:=StrLen(p);

  Result:=

         (Len>3)

         AND

         (i>2)

         AND

         (i<Len-2)

         AND

          (not (p[i] in Spaces))

         AND

          (not (p[i+1] in Spaces))

         AND

          (not (p[i-1] in Spaces))

         AND

         (

         (isSogl(p[i])and isGlas(p[i-1])and isSogl(p[i+1])and

Red_SlogMore(p,i+1))

         OR

((isGlas(p[i]))and(isSogl(p[i-1]))and(isSogl(p[i+1]))and(isGlas(p[i+2])))

         OR

         ((isGlas(p[i]))and(isSogl(p[i-1]))and(isGlas(p[i+1])) and

Red_SlogMore(p,i+1)  )

         OR

         ((isSpecSign(p[i])))

         );

end;

Function SetHyphString(s : String):String;

Var Res:PChar;

begin

  Res:=SetHyph(PChar(S),Length(S)*2)

  Result:=Res;

  FreeMem(Res,Length(S)*2);

end;

end.

Alex Gorbunov

acdc@media-press.donetsk.ua

www.media-press.donetsk.ua

(2:465/85.4)

.


12
Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе?

 под Windows 95 это возможно с использованием вспомогательных

инфоpмационных функций (tool help functions).Для получения списка пpоцессов надо делать следующее:

1. Cпеpва вызывается фукция

hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)

// - получение снимка состояния системы

2. Process32First() - получене инфоpмации о пеpвом пpоцессе в списке

3. Далее в цикле Process32Next() - получение инфоpмации о следующем   пpоцессе в списке

Dima Bogachev

(2:5020/1056.18)

Пример:

>== Режем pаз ==<

unit KernlUtl;

interface

uses TlHelp32, Windows, Classes, Sysutils;

procedure GetProcessList(List: TStrings);

procedure GetModuleList(List: TStrings);

function GetProcessHandle(ProcessID: DWORD): THandle;

procedure GetParentProcessInfo(var ID: DWORD; var Path: String);

const

  PROCESS_TERMINATE         =  $0001;

  PROCESS_CREATE_THREAD     =  $0002;

  PROCESS_VM_OPERATION      =  $0008;

  PROCESS_VM_READ           =  $0010;

  PROCESS_VM_WRITE          =  $0020;

  PROCESS_DUP_HANDLE        =  $0040;

  PROCESS_CREATE_PROCESS    =  $0080;

  PROCESS_SET_QUOTA         =  $0100;

  PROCESS_SET_INFORMATION   =  $0200;

  PROCESS_QUERY_INFORMATION =  $0400;

  PROCESS_ALL_ACCESS        =

    STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF;

implementation

procedure GetProcessList(List: TStrings);

var

  I: Integer;

  hSnapshoot: THandle;

  pe32: TProcessEntry32;

begin

  List.Clear;

  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

  if (hSnapshoot = -1) then

      Exit;

  pe32.dwSize := SizeOf(TProcessEntry32);

  if (Process32First(hSnapshoot, pe32)) then

  repeat

    I := List.Add(Format('%x, %x: %s',

      [pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile]));

    List.Objects[I] := Pointer(pe32.th32ProcessID);

  until not Process32Next(hSnapshoot, pe32);

  CloseHandle (hSnapshoot);

end;

procedure GetModuleList(List: TStrings);

var

  I: Integer;

  hSnapshoot: THandle;

  me32: TModuleEntry32;

begin

  List.Clear;

  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0);

  if (hSnapshoot = -1) then

      Exit;

  me32.dwSize := SizeOf(TModuleEntry32);

  if (Module32First(hSnapshoot, me32)) then

  repeat

    I := List.Add(me32.szModule);

    List.Objects[I] := Pointer(me32.th32ModuleID);

  until not Module32Next(hSnapshoot, me32);

  CloseHandle (hSnapshoot);

end;

procedure GetParentProcessInfo(var ID: DWORD; var Path: String);

var

  ProcessID: DWORD;

  hSnapshoot: THandle;

  pe32: TProcessEntry32;

begin

  ProcessID := GetCurrentProcessID;

  ID := -1;

  Path := '';

  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

  if (hSnapshoot = -1) then

      Exit;

  pe32.dwSize := SizeOf(TProcessEntry32);

  if (Process32First(hSnapshoot, pe32)) then

  repeat

    if pe32.th32ProcessID = ProcessID then

    begin

      ID := pe32.th32ParentProcessID;

      Break;

    end;

  until not Process32Next(hSnapshoot, pe32);

  if ID <> -1 then

  begin

    if (Process32First(hSnapshoot, pe32)) then

    repeat

      if pe32.th32ProcessID = ID then

      begin

        Path := pe32.szExeFile;

        Break;

      end;

    until not Process32Next(hSnapshoot, pe32);

  end;

  CloseHandle (hSnapshoot);

end;

function GetProcessHandle(ProcessID: DWORD): THandle;

begin

  Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID);

end;

end.

>== Режем два ==<

Vladimir Gaitanoff

(2:5020/880.5)

[WNT] Под Windows NT:

Исходный текст на языке Си.

#include <windows.h>

#include <stdio.h>

typedef long   (*NtQSI)(LONG, PVOID,LONG, LONG);

struct ThreadInfo

{

        FILETIME ftCreationTime;

        DWORD dwUnknown1;

        DWORD dwStartAddress;

        DWORD dwOwningPID;

        DWORD dwThreadID;

        DWORD dwCurrentPriority;

        DWORD dwBasePriority;

        DWORD dwContextSwitches;

        DWORD dwThreadState;

        DWORD dwUnknown2;

        DWORD dwUnknown3;

        DWORD dwUnknown4;

        DWORD dwUnknown5;

        DWORD dwUnknown6;

        DWORD dwUnknown7;

};

struct ProcessInfo

{

        DWORD dwOffset; // an ofset to the next Process structure

        DWORD dwThreadCount;

        DWORD dwUnkown1[6];

        FILETIME ftCreationTime;

        DWORD dwUnkown2;

        DWORD dwUnkown3;

        DWORD dwUnkown4;

        DWORD dwUnkown5;

        DWORD dwUnkown6;

        WCHAR* pszProcessName;

        DWORD dwBasePriority;

        DWORD dwProcessID;

        DWORD dwParentProcessID;

        DWORD dwHandleCount;

        DWORD dwUnkown7;

        DWORD dwUnkown8;

        DWORD dwVirtualBytesPeak;

        DWORD dwVirtualBytes;

        DWORD dwPageFaults;

        DWORD dwWorkingSetPeak;

        DWORD dwWorkingSet;

        DWORD dwUnkown9;

        DWORD dwPagedPool; // kbytes

        DWORD dwUnkown10;

        DWORD dwNonPagedPool; // kbytes

        DWORD dwPageFileBytesPeak;

        DWORD dwPageFileBytes;

        DWORD dwPrivateBytes;

        DWORD dwUnkown11;

        DWORD dwUnkown12;

        DWORD dwUnkown13;

        DWORD dwUnkown14;

        struct ThreadInfo ati[1];

};

    NtQSI ntqsi;

    HANDLE h;

    int i;

    long j;

    long tt;

    char *vt; // UNICODE

    struct ThreadInfo  *tinfo, *tinf2;

    struct ProcessInfo *pinfo;

    char buf[20480];

void main()

{

    h=LoadLibrary("NTDLL.DLL");

    ntqsi = (NtQSI)GetProcAddress(h,"NtQuerySystemInformation");

    j = (*ntqsi)(5,buf,20480,0);

    pinfo = buf;

    for(;;){

       vt = pinfo->pszProcessName;

       printf("%4lX|%13s|%8ld|%7lX|%7ld",

          pinfo->dwProcessID,vt,

          pinfo->dwThreadCount,pinfo->dwParentProcessID,

          pinfo->dwOffset);

       printf("|%4ld\n",pinfo->dwBasePriority);

       printf("\t|  ID|Owner|State|Priority|Base Priority\n");

       tinfo = &pinfo->ati[0];

       for(i=0;i<pinfo->dwThreadCount;++i){

          tinf2 = &tinfo[i];

          printf("\t|%4lX|%5lX|%5lX|%8s|%8s\n",

             tinf2->dwThreadID,

             tinf2->dwOwningPID,

             tinf2->dwThreadState,

             tinf2->dwCurrentPriority,

             tinf2->dwBasePriority);

       }

       if(pinfo->dwOffset==0) break;

       pinfo = (struct ProcessInfo*)((char *)pinfo + pinfo->dwOffset);

    }

}

Viktor Krapivin

(2:450/102.13)

.


13
Как добавить горизонтальную полосу прокрутки в TListBox?

Компонент VCL TListBox автоматически реализует вертикальную полосу прокрутки.Полоска прокрутки появляется, когда окно списка слишком мало для показа всех элементов списка. Однако окно списка не показывает горизонтальной полосы прокрутки, когда какие-либо элементы списка имеют большую ширину, чем само окно списка.Конечно, есть возможность добавить горизонтальную полосу прокрутки.

Добавьте следующий код в обработчик события OnCreate Вашей формы:

procedure TForm1.FormCreate(Sender: TObject);

var

  i, MaxWidth: integer;

begin

  MaxWidth := 0;

  for i := 0 to ListBox1.Items.Count - 1 do

    if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then

      MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);

    SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);

end;

Этот код находит ширину, в пикселах, самой длинной строки в окне списка.Затем он использует сообщение LB_SETHORIZONTALEXTENT для установки горизонтальной прокручиваемой ширины, в пикселах, для окна списка. Два дополнительных пиксела добавлены к MaxWidth,чтобы двинуть оконечные символы от правой границы окна списка.


14
Как сконверировать строку из одной кодировки в другую?

Для перекодирования из текущей кодировки DOS в текущую кодировку Windows есть функции

Win16: OemToAnsi, AnsiToOem;

Win32: OemToChar, CharToOem.

И они же с суффиксом Buf.

если Вы хотите работать с другими кодировками (ISO, 4e) или получить тот же результат вне зависимости системной локализации,

Примечание: не пытайся копировать таблицу из письма, так как здесь кодировка KOI8r, а набей ее сам вручную.

type

  TXlatTable = array[0..255] of Char;

  PXlatTable = ^TXlatTable;

const

  Cp866To1251 : TXlatTable = (

   #0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#10,#11,#12,#13,#14,#15,

   #16,#17,#18,#19,#20,#21,#22,#23,#24,#25,#26,#27,#28,#29,#30,#31,

   ' ','!','"','#','$','%','&','''','(',')','*','+',',','-','.','/',

    '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',

   '@','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',

    'P','Q','R','S','T','U','V','W','X','Y','Z','[','\',']','^','_',

    '`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',

    'p','q','r','s','t','u','v','w','x','y','z','{','|','}','~',#127,

   'А','Б','В','Г','Д','Е','Ж','З','И','Й','К','Л','М','H','О','П',

    'Р','С','Т','У','Ф','Х','Ц','Ч','Ш','Щ','Ъ','Ы','Ь','Э','Ю','Я',

    'а','б','в','г','д','е','ж','з','и','й','к','л','м','н','о','п',

    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',

    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',

    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',

    'р','с','т','у','ф','х','ц','ч','ш','щ','ъ','ы','ь','э','ю','я',

  'Ё','ё','?','ё','?','?','?','?','°','·','·',#251,'?','?',#254,#255);

function XlatConvert(const Value:string;

                     const CvtTable:PXlatTable): string;

Implementation

{***********************************

* Xlat Convering utility          *

* for Transliterate, Upper, Lower *

***********************************}

function XlatConvert(const Value:string;

                     const CvtTable:PXlatTable) : string;

var

  I : Integer;

begin

  if CvtTable = nil then

    Result := Value

  else begin

    Result := '';

    for I := 1 to Length(Value) do begin

      Result := Result + CvtTable^[Byte(Value[I])];

    end;

  end;

end; {XlatConvert}

Anatoly Podgoretsky

kvk@estpak.ee


15
Как отловить нажатия клавиш для всех процессов в системе?

Вот, может поможет:

>1. Setup.bat

=== Cut ===

@echo off

copy HookAgnt.dll %windir%\system

copy kbdhook.exe %windir%\system

start HookAgnt.reg

=== Cut ===

>2.HookAgnt.reg

=== Cut ===

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]

"kbdhook"="kbdhook.exe"

=== Cut ===

>3.KbdHook.dpr

=== Cut ===

program cwbhook;

uses Windows, Dialogs;

var

  hinstDLL: HINST;

  hkprcKeyboard: TFNHookProc;

  msg: TMsg;

begin

  hinstDLL := LoadLibrary('HookAgnt.dll');

  hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');

  SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);

  repeat until not GetMessage(msg, 0, 0, 0);

end.

=== Cut ===

>4.HookAgnt.dpr

=== Cut ===

library HookAgent;

uses Windows, KeyboardHook in 'KeyboardHook.pas';

exports

  KeyboardProc;

var

  hFileMappingObject: THandle;

  fInit: Boolean;

{----------------------------\

|                            |

|     DLL_PROCESS_DETACH     |

|                            |

\----------------------------}

procedure DLLMain(Reason: Integer);

begin

  if Reason = DLL_PROCESS_DETACH then

  begin

    UnmapViewOfFile(lpvMem);

    CloseHandle(hFileMappingObject);

  end;

end;

{----------------------------\

|                            |

|     DLL_PROCESS_ATTACH     |

|                            |

\----------------------------}

begin

  DLLProc := @DLLMain;

  hFileMappingObject := CreateFileMapping(

    THandle($FFFFFFFF), // use paging file

    nil,                // no security attributes

    PAGE_READWRITE,     // read/write access

    0,                  // size: high 32 bits

    4096,               // size: low 32 bits

    'HookAgentShareMem' // name of map object

  );

  if hFileMappingObject = INVALID_HANDLE_VALUE then

  begin

    ExitCode := 1;

    Exit;

  end;

  fInit := GetLastError() <> ERROR_ALREADY_EXISTS;

  lpvMem := MapViewOfFile(

    hFileMappingObject, // object to map view of

    FILE_MAP_WRITE,     // read/write access

    0,                  // high offset: map from

    0,                  // low offset:  beginning

    0                   // default: map entire file

  );

  if lpvMem = nil then

  begin

    CloseHandle(hFileMappingObject);

    ExitCode := 1;

    Exit;

  end;

  if fInit then

    FillChar(lpvMem, PASSWORDSIZE, #0);

end.

=== Cut ===

>5.KeyboardHook.pas

=== Cut ===

unit KeyboardHook;

interface

uses Windows;

{------------------------------------------\

|                                          |

|     +ыюсрыcэvх яхЁхьхээvх ш ъюэё?рэ?v    |

|                                          |

\------------------------------------------}

const

  PASSWORDSIZE = 16;

var

  g_hhk: HHOOK;

  g_szKeyword: array[0..PASSWORDSIZE-1] of char;

  lpvMem: Pointer;

function KeyboardProc(nCode: Integer; wParam: WPARAM;

  lParam: LPARAM ): LRESULT; stdcall;

implementation

uses SysUtils, Dialogs;

function KeyboardProc(nCode: Integer; wParam: WPARAM;

  lParam: LPARAM ): LRESULT;

var

  szModuleFileName: array[0..MAX_PATH-1] of Char;

  szKeyName: array[0..16] of Char;

  lpszPassword: PChar;

begin

  lpszPassword := PChar(lpvMem);

  if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then

  begin

    GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));

    if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then

      lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));

    lstrcat(g_szKeyword, szKeyName);

    GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName));

>    if (StrPos(StrUpper(szModuleFileName),'__ТО_ЧЕГО_

АДО__') <> nil) and

       (strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then

      lstrcat(lpszPassword, szKeyName);

    if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then

    begin

      ShowMessage(lpszPassword);

      g_szKeyword[0] := #0;

    end;

    Result := 0;

  end

  else

    Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);

end;

end.

=== Cut ===

Alexander Tkachenko

(2:5055/62.6)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


16
Как вывести на Canvas надпись под углом?

Вот, взгляни.

...

function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;

  {-create a rotated font based on the font object F}

var

  LF : TLogFont;

begin

  FillChar(LF, SizeOf(LF), #0);

  with LF do begin

    lfHeight           := F.Height;

    lfWidth            := 0;

    lfEscapement       := Angle*10;

    lfOrientation      := 0;

    if fsBold in F.Style then

      lfWeight         := FW_BOLD

    else

      lfWeight         := FW_NORMAL;

    lfItalic           := Byte(fsItalic in F.Style);

    lfUnderline        := Byte(fsUnderline in F.Style);

    lfStrikeOut        := Byte(fsStrikeOut in F.Style);

    lfCharSet          := DEFAULT_CHARSET;

    StrPCopy(lfFaceName, F.Name);

    lfQuality          := DEFAULT_QUALITY;

    {everything else as default}

    lfOutPrecision     := OUT_DEFAULT_PRECIS;

    lfClipPrecision    := CLIP_DEFAULT_PRECIS;

    case F.Pitch of

      fpVariable : lfPitchAndFamily := VARIABLE_PITCH;

      fpFixed    : lfPitchAndFamily := FIXED_PITCH;

    else

      lfPitchAndFamily := DEFAULT_PITCH;

    end;

  end;

  Result := CreateFontIndirect(LF);

end;

...

  {create the rotated font}

  if FontAngle <> 0 then

    Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);

...

Вращаются только векторные шрифты.

Nikita Popov

nix@tekton.dol.ru

(2:5020/87.2)

.


17
Как из программы переключать языки?

Здесь переключатели на русский и на английский.

procedure SetRU;

var

  Layout: array[0.. KL_NAMELENGTH] of char;

begin

  LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);

end;

procedure SetEN;

var

  Layout: array[0.. KL_NAMELENGTH] of char;

begin

  LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE);

end;

Anton Geleznyak(2:5000/106)

Можно и так:

var rus, lat: HKL;

rus:=LoadKeyboardLayout('00000419', 0);

lat:=LoadKeyboardLayout('00000409', 0);

SetActiveKeyboardLayout(rus);

Valentin Lavrinenko(2:463/566.110)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


18
Как удобнее работать с буфером обмена как последовательностью байт?

Используя потоки -

=== Cut ===

unit ClipStrm;

{

  This unit is Copyright (c) Alexey Mahotkin 1997-1998

  and may be used freely for any purpose. Please mail

  your comments to

  E-Mail: alexm@hsys.msk.ru

  FidoNet: Alexey Mahotkin, 2:5020/433

  This unit was developed during incorporating of TP Lex/Yacc

  into my project. Please visit ftp://ftp.nf.ru/pub/alexm

  or FREQ FILES from 2:5020/433 or mail me to get hacked

  version of TP Lex/Yacc which works under Delphi 2.0+.

}

interface uses Classes, Windows;

type

  TClipboardStream = class(TStream)

  private

    FMemory : pointer;

    FSize : longint;

    FPosition : longint;

    FFormat : word;

  public

    constructor Create(fmt : word);

    destructor Destroy; override;

    function Read(var Buffer; Count : Longint) : Longint; override;

    function Write(const Buffer; Count : Longint) : Longint; override;

    function Seek(Offset : Longint; Origin : Word) : Longint; override;

  end;

implementation uses SysUtils;

constructor TClipboardStream.Create(fmt : word);

var

  tmp : pointer;

  FHandle : THandle;

begin

FFormat := fmt;

OpenClipboard(0);

FHandle := GetClipboardData(FFormat);

FSize := GlobalSize(FHandle);

FMemory := AllocMem(FSize);

tmp := GlobalLock(FHandle);

MoveMemory(FMemory, tmp, FSize);

GlobalUnlock(FHandle);

FPosition := 0;

CloseClipboard;

end;

destructor TClipboardStream.Destroy;

begin

FreeMem(FMemory);

end;

function TClipboardStream.Read(var Buffer; Count : longint) : longint;

begin

if FPosition + Count > FSize then

  Result := FSize - FPosition

else

  Result := Count;

MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);

Inc(FPosition, Result);

end;

function TClipboardStream.Write(const Buffer; Count : longint) : longint;

var

  FHandle : HGlobal;

  tmp : pointer;

begin

ReallocMem(FMemory, FPosition + Count);

MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);

FPosition := FPosition + Count;

FSize := FPosition;

FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);

try

  tmp := GlobalLock(FHandle);

  try

    MoveMemory(tmp, FMemory, FSize);

    OpenClipboard(0);

    SetClipboardData(FFormat, FHandle);

  finally

    GlobalUnlock(FHandle);

  end;

  CloseClipboard;

except

  GlobalFree(FHandle);

end;

Result := Count;

end;

function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;

begin

case Origin of

0 : FPosition := Offset;

1 : Inc(FPosition, Offset);

2 : FPosition := FSize + Offset;

end;

Result := FPosition;

end;

end.

=== Cut ===

Alexey Mahotkin alexm@hsys.msk.ru (2:5020/433)

.


19
Как взять хэндл рабочего стола для манипуляций с иконками рабочего стола?

Рабочий стол перекрыт сверху компонентом ListView.

Вам просто необходимо взять хэндл этого органа управления. Пример:

function GetDesktopListViewHandle: THandle;

var

  S: String;

begin

  Result := FindWindow('ProgMan', nil);

  Result := GetWindow(Result, GW_CHILD);

  Result := GetWindow(Result, GW_CHILD);

  SetLength(S, 40);

  GetClassName(Result, PChar(S), 39);

  if PChar(S) <> 'SysListView32' then Result := 0;

end;

После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView,определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом.Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32.

К примеру, следующая строка кода:

SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 );

разместит иконки рабочего стола по левой стороне рабочего стола Windows.

(Borland FAQ N687, переведен Акжаном Абдулиным)

.


20
Можно пpимеp получить, как копиpовать файлы?

Можно так:

procedure CopyFile(const FileName, DestName: TFileName);

var

  CopyBuffer: Pointer; { buffer for copying }

  TimeStamp, BytesCopied: Longint;

  Source, Dest: Integer; { handles }

  Destination: TFileName; { holder for expanded destination name }

const

  ChunkSize: Longint = 8192; { copy in 8K chunks }

begin

  Destination := ExpandFileName(DestName); { expand the destination path }

  if HasAttr(Destination, faDirectory) then { if destination is a directory...

}

    Destination := Destination + '\' + ExtractFileName(FileName); { ...clone

file name }

  TimeStamp := FileAge(FileName); { get source's time stamp }

  GetMem(CopyBuffer, ChunkSize); { allocate the buffer }

  try

    Source := FileOpen(FileName, fmShareDenyWrite); { open source file }

    if Source < 0 then raise EFOpenError.Create(FmtLoadStr(SFOpenError,

[FileName]));

    try

      Dest := FileCreate(Destination); { create output file; overwrite existing

}

      if Dest < 0 then raise EFCreateError.Create(FmtLoadStr(SFCreateError,

[Destination]));

      try

        repeat

          BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk

}

          if BytesCopied > 0 then { if we read anything... }

            FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }

        until BytesCopied < ChunkSize; { until we run out of chunks }

      finally

        FileClose(Dest); { close the destination file }

{        SetFileTimeStamp(Destination, TimeStamp);} { clone source's time stamp

}{!!!}

      end;

    finally

      FileClose(Source); { close the source file }

    end;

  finally

    FreeMem(CopyBuffer, ChunkSize); { free the buffer }

Текст: D:\DELPHI\WORK\ID_LIB.PAS        Ст. 0

  end;

FileSetDate(Dest,FileGetDate(Source));

end;

Anton Kartamyshev(2:5020/211.15)

Хм. ИМХО кpутовато будет такие ф-ии писать когда в большинстве

случаев достаточно что-нть типа нижепpиводимого, пpичем оно даже гибче,так как позволяет скопиpовать как весь файл пpи From и Count = 0,так и пpоизвольный его кусок.

  function CopyFile( InFile,OutFile: String; From,Count: Longint ): Longint;

  var

    InFS,OutFS: TFileStream;

  begin

    InFS  := TFileStream.Create( InFile,  fmOpenRead );

    OutFS := TFileStream.Create( OutFile, fmCreate   );

    InFS.Seek( From, soFromBeginning );

    Result := OutFS.CopyFrom( InFS, Count );

    InFS.Free;

    OutFS.Free;

  end;

  try..except pасставляются по вкусу, а навоpоты вpоде установки

атpибутов,даты и вpемени файла и т.п. для ясности удалены, да и не нужны   они в основном никогда.

Dimus Gremyakoff dimus57@chat.ru, dimus.g@usa.net

(2:5020/768.57)

Конечно, под Win32 имеет смысл использовать функции CopyFile, SHFileOperation.


21
Как мне отправить на принтер чистый поток данных?

Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает последнее.Под Win32 Вы можете использовать WritePrinter.

Ниже пример открытия принтера и записи чистого потока данных в принтер.Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet5MP",чтобы функция сработала успешно.

Конечно, Вы можете включать в поток данных любые необходимые управляющие коды,которые могут потребоваться.

uses WinSpool;

procedure WriteRawStringToPrinter(PrinterName:String; S:String);

var

  Handle: THandle;

  N: DWORD;

  DocInfo1: TDocInfo1;

begin

  if not OpenPrinter(PChar(PrinterName), Handle, nil) then

  begin

    ShowMessage('error ' + IntToStr(GetLastError));

    Exit;

  end;

  with DocInfo1 do begin

    pDocName := PChar('test doc');

    pOutputFile := nil;

    pDataType := 'RAW';

  end;

  StartDocPrinter(Handle, 1, @DocInfo1);

  StartPagePrinter(Handle);

  WritePrinter(Handle, PChar(S), Length(S), N);

  EndPagePrinter(Handle);

  EndDocPrinter(Handle);

  ClosePrinter(Handle);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

  WriteRawStringToPrinter('HP', 'Test This');

end;

(Borland FAQ N714, переведен Акжаном Абдулиным)

.


22
Как я могу использовать анимированный курсор?

Сперва Вы должны взять хэндл курсора Windows и присвоить его одному из элементов массива Cursors обьекта Screen.

Предопределенные курсоры имеют отрицательный индекс, а определенные пользователем (Вами) курсоры получают положительные индексы.Ниже пример формы, использующей анимированный курсор:

procedure TForm1.Button1Click(Sender: TObject);

var

  h : THandle;

begin

  h := LoadImage(0,

    'C:\TheWall\Magic.ani',

    IMAGE_CURSOR,

    0,

    0,

    LR_DEFAULTSIZE or

    LR_LOADFROMFILE

  );

  if h = 0 then ShowMessage('Cursor not loaded')

  else

  begin

    Screen.Cursors[1] := h;

    Form1.Cursor := 1;

  end;

end;

(Borland FAQ N696, переведен Акжаном Абдулиным)

.


23
Как исправить проблемы с русскими шрифтами *.TTF в Delphi 3 + Windows NT 4.0 + Service Pack 3.

Борланды тут ни при чем - родной Character Map точно так же себя ведет :-(    Попробуй сделать

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\FontMapper]

DEFAULT=0xcc (204) вместо 0x00 (Именно DEFAULT, а не (Default):-)

Alex Petin(2:5000/45.10)

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\WindowsNT\CurrentVersion\FontMapperDEFAULT=0x000000cc

pекомендую взглянуть на это:

=== Cut ===

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows

NT\CurrentVersion\FontSubstitutes ]

"Times"="Times New Roman,204"

"Helvetica"="Arial,204"

"MS Shell Dlg"="MS Sans Serif"

"System,0"="System,204"

"Fixedsys,0"="Fixedsys,204"

"Small Fonts,0"="Small Fonts,204"

"MS Serif,0"="MS Serif,204"

"MS Sans Serif,0"="MS Sans Serif,204"

"Courier,0"="Courier New,204"

"Arial Cyr,0"="Arial,204"

"Courier New Cyr,0"="Courier New,204"

"Times New Roman Cyr,0"="Times New Roman,204"

"Tms Rmn,0"="MS Serif,204"

"Helv,0"="MS Sans Serif,204"

"Arial,0"="Arial,204"

"Courier New,0"="Courier New,204"

=== Cut ===

Суть, я думаю, ясна: для всех используемых Вами UNICODE фонтов явно пpописываете кодовую стpаницу cp1251. Это, кстати, поможет заодно и тем, кто жаловался, что Delphi не хочет понимать Arial Cyr.

Alex Konshin(2:5030/217)

.


24
Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как сделать?

unit BetterTreeView;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  ComCtrls, CommCtrl;

type

  TTVNewEditCancelEvent = procedure( Sender: TObject;

    Node: TTreeNode; var Delete: Boolean) of object;

  TBetterTreeView = class(TTreeView)

  protected

    FIsEditingNew: Boolean;

    FOnEditCancel: TTVChangedEvent;

    FOnNewEditCancel: TTVNewEditCancelEvent;

    procedure Edit(const Item: TTVItem); override;

  public

    function NewChildAndEdit(Node: TTreeNode; const S: String)

      : TTreeNode;

  published

    property IsEditingNew: Boolean read FIsEditingNew;

    property OnEditCancel: TTVChangedEvent

      read FOnEditCancel write FOnEditCancel;

    property OnNewEditCancel: TTVNewEditCancelEvent

      read FOnNewEditCancel write FOnNewEditCancel;

  end;

implementation

procedure TBetterTreeView.Edit(const Item: TTVItem);

var

  Node: TTreeNode;

  Action: Boolean;

begin

  with Item do begin

    { Get the node }

    if (state and TVIF_PARAM) <> 0 then

      Node := Pointer(lParam)

    else

      Node := Items.GetNode(hItem);

    if pszText = nil then begin

      if FIsEditingNew then begin

        Action := True;

        if Assigned(FOnNewEditCancel) then

          FOnNewEditCancel(Self, Node, Action);

        if Action then

          Node.Destroy

      end

      else

        if Assigned(FOnEditCancel) then

          FOnEditCancel(Self, Node);

    end

    else

      inherited;

  end;

  FIsEditingNew := False;

end;

function TBetterTreeView.NewChildAndEdit

  (Node: TTreeNode; const S: String): TTreeNode;

begin

  SetFocus;

  Result := Items.AddChild(Node, S);

  FIsEditingNew := True;

  Node.Expand(False);

  Result.EditText;

  SetFocus;

end;

end.

Том Сван "Секреты..."

.


25
Как создать disable'ный битмап из обычного (emboss etc)?

CreateMappedBitmap() :-)

Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь пеpекодиpовкy, цвета подбеpешь сам из пpинципа:

все самые яpкие -> в GetSysColor( COLOR_3DLIGHT );

самые  темные -> GetSysColor( COLOR_3DSHADOW );

нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE );

Serge Zakharchuk(2:5060/32)

Так на самом деле вот как делается данная задача:

============

procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap);

var

  TmpImage,Monobmp:TBitmap;

  IRect:TRect;

begin

  MonoBmp := TBitmap.Create;

  TmpImage:=Tbitmap.Create;

  TmpImage.Width := bmpFrom.Width;

  TmpImage.Height := bmpFrom.Height;

  IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);

  TmpImage.Canvas.Brush.Color := clBtnFace;

  try

    with MonoBmp do

    begin

      Assign(bmpFrom);

      Canvas.Brush.Color := clBlack;

      if Monochrome then

      begin

        Canvas.Font.Color := clWhite;

        Monochrome := False;

        Canvas.Brush.Color := clWhite;

      end;

      Monochrome := True;

    end;

    with TmpImage.Canvas do

    begin

      Brush.Color := clBtnFace;

      FillRect(IRect);

      Brush.Color := clBlack;

      Font.Color := clWhite;

      CopyMode := MergePaint;

      Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);

      CopyMode := SrcAnd;

      Draw(IRect.Left, IRect.Top, MonoBmp);

      Brush.Color := clBtnShadow;

      Font.Color := clBlack;

      CopyMode := SrcPaint;

      Draw(IRect.Left, IRect.Top, MonoBmp);

      CopyMode := SrcCopy;

      bmpTo.assign(TmpImage);

      TmpImage.free;

    end;

  finally

    MonoBmp.Free;

  end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

  aaa(image1.picture.bitmap,image2.picture.bitmap);

  Image2.invalidate;

end;

============

Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph.  Как раз из него я это и выдернул).

Hу а если уже совсем хорошо разобраться, то можно заметить  функцию ImageList_DrawEx, в которой можно на 25 и 50 процентов уменьшить яркость (но визуально это очень плохо воспринимается). Соответственно параметры ILD_BLEND25, ILD_BLEND50, ILD_BLEND-A-MED. Естественно, что последний абзац работает только с тройкой.

Denis Tanayeff denis@demo.ru

Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.

====================

#define CO_GRAY         0x00C0C0C0L

hMemDC      =       CreateCompatibleDC(hDC);

hOldBitmap  =   SelectObject(hMemDC, hBits);

   //  hBits это собственно картинка, которую надо "засерить"

GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap);

if ( GetState(BS_DISABLED) ) // Blt disabled

{

    hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY

    PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,

            Bitmap.bmHeight, PATCOPY);

    DeleteObject(SelectObject(hDC, hOldBrush));

    lbLogBrush.lbStyle = BS_PATTERN;

    lbLogBrush.lbHatch =(int)LoadBitmap(hInsts,

MAKEINTRESOURCE(BT_DISABLEBITS));

    hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush));

    BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,

                Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa

    DeleteObject(SelectObject(hDC, hOldBrush));

    DeleteObject((HGDIOBJ)lbLogBrush.lbHatch);

}

==================

Andy Nikishin

http://www.gs.ru/~links/andy.shtml

(2:5031/16.2)

.


26
Как запретить кнопку Close [x] в заголовке окна.

Вот кусок, который делает все, что тебе нужно:

procedure TForm1.FormCreate(Sender: TObject);

var

  Style: Longint;

begin

  Style := GetWindowLong(Handle, GWL_STYLE);

  SetWindowLong(Handle, GWL_STYLE, Style And Not WS_SYSMENU);

end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

  Shift: TShiftState);

begin

  if (Key = VK_F4) and (ssAlt in Shift) then begin

    MessageBeep(0);

    Key := 0;

  end;

end;

Alexander Petrushev(2:5001/88.10)

'а самом деле есть более простой способ (запрет на SC_CLOSE),

но я уже деталей его не помню.

Akzhan Abdulin(2:5040/55)

=== Cut ===

{ Disable close button }

procedure TForm1.Button1Click(Sender: TObject);

var

  SysMenu: HMenu;

begin

  SysMenu := GetSystemMenu(Handle, False);

  Windows.EnableMenuItem(SysMenu, SC_CLOSE, MF_DISABLED or MF_GRAYED);

end;

{ Enable close button }

procedure TForm1.Button2Click(Sender: TObject);

begin

  GetSystemMenu(Handle, True);

  Perform(WM_NCPAINT, Handle, 0);

end;

=== Cut ===

Но это окно можно закрыть из TaskBar'а.

Vlad Filyakov(2:5022/26.9)

И все же, кажется, я делал иначе. :(

Akzhan Abdulin

(2:5040/55)


27
Как скопировать экран (или его часть) в TBitmap?

Например, с помощью WinAPI так -

var

 bmp: TBitmap;

 DC: HDC;

begin

 bmp:=TBitmap.Create;

 bmp.Height:=Screen.Height;

 bmp.Width:=Screen.Width;

 DC:=GetDC(0);  //Дескpиптоp экpана

 bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,

       DC, 0, 0, SRCCOPY);

 bmp.SaveToFile('Screen.bmp');

 ReleaseDC(0, DC);

end;

Peter Maishev(2:5020/1530.31)

Или с помощью обертки TCanvas -

Объект Screen[.width,height] - размеры

Var

 Desktop :TCanvas ;

 BitMap  :TBitMap;

begin

  DesktopCanvas:=TCanvas.Create;

  DesktopCanvas.Handle:=GetDC(Hwnd_Desktop);

  BitMap := TBitMap.Create;

  BitMap.Width := Screen.Width;

  BitMap.Height:=Screen.Height;

  Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect,

  DesktopCanvas, DesktopCanvas.ClipRect);

  ........

end;

Serg Lukashov

serg@tnd.belpak.gomel.by, serg.d.lukashov@usa.net

(2:452/9.16)

.


28
Как убрать всплывающие подсказки в TreeView?

TCustomTreeView.WMNotify. О том, что такое тип notify'а TTM_NEEDTEXT пpочтешь в хелпе. Убpать хинты можно, пеpекpыв

обpаботчик для этого уведомительного сообщения.

Eugene Mayevski

Eugene-Mayevski@usa.net

(2:463/209.209)

.


29
Как изменить внешний вид хинтов (всплывающих подсказок)?

1. Создаем свой класс - потомок от THintWindow

  type

    TCustomHint = class (THintWindow)

    public

      constructor Create(AOwner: TComponent); override;

    end;

  Пpимечание 1. Этот способ не позволит изменить цвет шpифта  для этого пpидется пеpекpывать метод Paint;

  Пpимечание 2. Если пеpекpыть CreateParams, то можно, напpимеp, наpисовать Hint в фоpме облачка.

  Пpимечание 3. Для изменения цвета фона F1 Application.OnShowHint, HintInfo.

2. Меняем фонт:

  constructor TCustomHint.Create(AOwner: TComponent);

  begin

    inherited Create(AOwner);

    with Canvas.Font do               // Именно так, а не пpосто Font!

    begin

      Name := 'Times New Roman Cyr';

      Style := [fsBold, fsItalic];

      Size := 40;

    end;

  end;

3. Устанавливаем новый хинт

  procedure TForm1.FormCreate(Sender: TObject); // Это может быть любой

  begin                                         // обpаботчик

    HintWindowClass := TMyHint;      // Устанавливаем глобальную пеpеменную

    Application.ShowHint := false;   // Application.FHintWindow.Free

    Application.ShowHint := true;    // Application.FHintWindow.Create

  end;

Литеpатуpа:

1. <...>\Source\VCL\Forms.pas (TApplication).

2. <...>\Source\VCL\Controls.pas (THintWindow).

3. Delphi Help (OnShowHint, THintInfo).

Dmitry Medved

(2:464/58.7)

.


30
Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения (взять и перенести)?

Пример:

{ В случае Panel1:TPanel - обработчик события OnMouseDown }

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;

    Shift: TShiftState; X, Y: Integer);

const

  SC_DragMove = $F012;  { a magic number }

begin

  ReleaseCapture;

  panel1.perform(WM_SysCommand, SC_DragMove, 0);

end;

Borland TI N2909

(перевод: Акжан Абдулин)

.


31
Базы данных

1

2

34


32
Как послать самостийное сообщение всем главным окнам в Windows?

Пример:

Var

 FM_FINDPHOTO: Integer;

// Для использовать hwnd_Broadcast нужно сперва зарегистрировать //уникальное сообщение

Initialization

 FM_FindPhoto:=RegisterWindowMessage('MyMessageToAll');

// Чтобы поймать это сообщение в другом приложении (приемнике) нужно перекрыть

DefaultHandler

procedure TForm1.DefaultHandler(var Message);

begin

  with TMessage(Message) do

  begin

    if Msg = Fm_FindPhoto then MyHandler(WPARAM,LPARAM)  else

    Inherited DefaultHandler(Message);

  end;

end;

// А тепрь можно

SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0);

Кстати, для посылки сообщения дочерним контролам некоего контрола можно использовать метод Broadcast.

Andrey Burov

(2:463/238.19)


33
Как проиграть Wave-ресурс?

 Сначала делаешь файл SOUND.RC, в нем строка вида: MY_WAV RCDATA TEST.WAV

 Компилишь чем-нибyдь в *.RES

 Далее в тексте:

{$R полное_имя_файла_с_ресурсом}

 var WaveHandle  : THandle;

       WavePointer : pointer;

 ...

  WaveHandle  := FindResource(hInstance,'MY_WAV',RT_RCDATA);

   if WaveHandle<>0 then begin

     WaveHandle:= LoadResource(hInstance,WaveHandle);

      if WaveHandle<>0 then begin;

         WavePointer := LockResource(WaveHandle);

          PlayResourceWave := sndPlaySound(WavePointer,snd_Memory OR

SND_ASYNC);

          UnlockResource(WaveHandle);

          FreeResource(WaveHandle);

      end;

  end;

Serg Vostrikov

(2:5053/15.3)


34
Как правильно завершить некое приложение?

Если не принудительно, то можно послать на его Instance сообщение WM_QUIT.Если же необходимо принудительно терминировать приложение, то смотрите ниже

Под Windows NT процесс можно терминировать через специально предназначенный для этого хэндл. Иначе гарантии нет.

Предположим, что процесс создаем мы, ожидая его завершения в течение maxworktime. Тогда

var

  dwResult: Longint; // This example was converted from C source.

begin                // Not tested. Some 'nil' assignments must be applied

                     // as zero assignments in Pascal. Some vars need to

                     // be declared (maxworktime, si, pi). AA.

  if CreateProcess(nil, CmdStr, nil, nil, FALSE,

                              CREATE_NEW_CONSOLE, nil, nil, si, pi) then

  begin

    CloseHandle( pi.hThread );

    dwResult := WaitForSingleObject(pi.hProcess, maxworktime*1000*60);

    CloseHandle( pi.hProcess );

    if dwResult <> WAIT_OBJECT_0 then

    begin

      pi.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, pi.dwProcessId);

      if pi.hProcess <> nil then

      begin

          TerminateProcess(pi.hProcess, 0);

          CloseHandle(pi.hProcess);

      end;

    end;

  end;

end;

Serge Nozhenko

(2:5020/175)

.


35
Как отобразить некоторые окна своей программы в панели задач Windows(помимо главного окна)

Hапример, так:

  procedure TMyForm.CreateParams(var Params :TCreateParams); {override;}

  begin

    inherited CreateParams(Params); {CreateWindowEx}

    Params.ExStyle := Params.ExStyle or WS_Ex_AppWindow;

  end;

Max Rusov

(2:5030/456.1)


36
Как изменить цвет отмеченных записей в DBGrid?

 Hапример, так:

 DefaultDrawing:=False;

 ....

procedure TfrmCard.GridDrawColumnCell(Sender: TObject; const Rect: TRect;

                                          DataCol: Integer; Column: TColumn;

                                          State: TGridDrawState);

var

  Index   : Integer;

  Marked,

  Selected: Boolean;

begin

  Marked := False;

  if (dgMultiSelect in Grid.Options) and THackDBGrid(Grid).Datalink.Active then

    Marked

:=Grid.SelectedRows.Find(THackDBGrid(Grid).Datalink.Datasource.Dataset.Bookmark

, Index);

  Selected := THackDBGrid(Grid).Datalink.Active and (Grid.Row-1 =

                                THackDBGrid(Grid).Datalink.ActiveRecord);

  if Marked then begin

    Grid.Canvas.Brush.Color:=$DFEFDF;;

    Grid.Canvas.Font.Color :=clBlack;

  end;

  if Selected then begin

    Grid.Canvas.Brush.Color:=$FFFBF0;

    Grid.Canvas.Font.Color :=clBlack;

    if Marked then

      Grid.Canvas.Brush.Color:=$EFE3DF; { $8F8A30 }

  end;

  Grid.DefaultDrawColumnCell(Rect, DataCol, Column, State);

end;

где

  THackDBGrid = class(TDBGrid)

    property DataLink;

    property UpdateLock;

  end;

Vadim Puzanov

vadim@mimex.krasnoyarsk.su

(2:5090/20)


37
Как проверить, имеем ли мы административные привилегии в системе?

// Routine: check if the user has administrator provileges

// Was converted from C source by Akzhan Abdulin. Not properly tested.

type

 PTOKEN_GROUPS = TOKEN_GROUPS^;

function RunningAsAdministrator (): Boolean;

var

 SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;

 psidAdmin: PSID;

 ptg: PTOKEN_GROUPS = nil;

 htkThread: Integer; { HANDLE }

 cbTokenGroups: Longint; { DWORD }

 iGroup: Longint; { DWORD }

 bAdmin: Boolean;

begin

    Result := false;

    if not OpenThreadToken(GetCurrentThread(),      // get security token

                        TOKEN_QUERY,

                        FALSE,

                        htkThread) then

       if GetLastError() = ERROR_NO_TOKEN then

       begin

          if not OpenProcessToken(GetCurrentProcess(),

                               TOKEN_QUERY,

                               htkThread) then

          Exit;

       end

       else

          Exit;

    if GetTokenInformation(htkThread,            // get #of groups

                           TokenGroups,

                           nil,

                           0,

                           cbTokenGroups) then

       Exit;

    if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then

       Exit;

    ptg := PTOKEN_GROUPS( getmem( cbTokenGroups ) );

    if not Assigned(ptg) then

       Exit;

    if not GetTokenInformation(htkThread,           // get groups

                            TokenGroups,

                            ptg,

                            cbTokenGroups,

                            cbTokenGroups) then

       Exit;

    if not AllocateAndInitializeSid(SystemSidAuthority,

                                 2,

                                 SECURITY_BUILTIN_DOMAIN_RID,

                                 DOMAIN_ALIAS_RID_ADMINS,

                                 0, 0, 0, 0, 0, 0,

                                 psidAdmin) then

       Exit;

    iGroup := 0;

    while iGroup < ptg^.GroupCount do // check administrator group

    begin

       if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then

       begin

          Result := TRUE;

          break;

       end;

       Inc( iGroup );

    end;

    FreeSid(psidAdmin);

end;

Andy Nikolayev

an@megatel.msk.su

(2:5020/56)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


38
Как вставить в StatusPanel свои компоненты, например ProgressBar?

pgProgress положить на форму как Visible := false;

StatusPanel надо OwnerDraw сделать и pефpешить, если Position меняется.

>== Режем pаз ==<

procedure TMainForm.stStatusBarDrawPanel(StatusBar: TStatusBar;

  Panel: TStatusPanel; const Rect: TRect);

begin

  if Panel.Index = pnProgress then

  begin

    pgProgress.BoundsRect := Rect;

    pgProgress.PaintTo(stStatusBar.Canvas.Handle, Rect.Left, Rect.Top);

  end;

end;

>== Режем два ==<

Vladimir Gaitanoff

vg@divo.ru

(2:50/430.2)

.


39
Как отчитывать промежутки времени с точностью, большей чем 60 мсек?

Для начала описываешь процедуру, которая будет вызываться по сообщению от таймера :

procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD)

stdcall;

begin

//

//  Тело процедуры.

end;

а дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь на него созданную процедуру

  uTimerID:=timeSetEvent(10,500,@FNTimeCallBack,100,TIME_PERIODIC);

Подробности смотри в Help.

Hу и в конце  убиваешь таймер

  timeKillEvent(uTimerID);

И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек.

Leonid Tserling

tlv@f3334.dd.vaz.tlt.ru


40
Как вставить в нужное место Rich Text в Rich Text Control?

Вы можете послать сообщение EM_STREAMIN с параметром SFF_SELECTION методом Perform для замены текущего Selection. Выдержка из Help:

EM_STREAMIN

wParam = (WPARAM) (UINT) uFormat; // Integer

lParam = (LPARAM) (EDITSTREAM FAR *) lpStream; // EDITSTREAM^

The EM_STREAMIN message replaces the contents of a rich edit control with the specified data stream.

Parameters

uFormat

One of the following data formats, optionally combined with the SFF_SELECTION

flag:

Value Meaning

SF_TEXT Text

SF_RTF Rich-text format

If the SFF_SELECTION flag is specified, the stream replaces the contents of the current selection. Otherwise, the stream replaces the entire contents of the

control.

lpStream

Pointer to an EDITSTREAM structure. The control reads (streams in) the data by repeatedly calling the function specified by the structure's pfnCallback

member.

Return Value

Returns the number of characters read.

Mikhail Chernyshev

Mikhail-Chernyshev@usa.net

(2:4615/26)

.


41
Как указать максимальный размер текста для RichEdit Control?

У этого компонента есть свойство MaxLength, которое работает некорректно. Поэтому лучше пользоваться RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);Причем перед каждом открытии файла это действие необходимо повторять.

Maxim Liverovskiy

(2:5030/254.38)

Если Вы передаете в качестве размера 0, то ОС ограничивает размер OS Specific Default Value. Реально, по результатам моих экспериментов, поставить можно размер, чуть меньший доступной виртуальной памяти. Я ограничился 90% от свободной виртуалки.

Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться сообщением EM_EXLIMITTEXT.

Stas Mehanoshin

(2:5030/143.23)


42
Как инсталлировать на время работы программы свои шрифты?

Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно след. образом:

{$IFDEF WIN32}

    AddFontResource( PChar( my_font_PathName { AnsiString } ) );

{$ELSE}

var

    ss  : array [ 0..255 ] of Char;

    AddFontResource ( StrPCopy ( ss, my_font_PathName ));

{$ENDIF}

    SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );

Убрать его по окончании работы:

{$IFDEF WIN32}

    RemoveFontResource ( PChar(my_font_PathName) );

{$ELSE}

    RemoveFontResource ( StrPCopy ( ss, my_font_PathName ));

{$ENDIF}

    SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );

При этом не надо никаких перезагрузок и прочего, после добавления фонт сразу можно использовать. my_font_PathName : string ( не string[nn] для D2+) - содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают.Если его не удалить, он (кажется) так и останется проинсталенным, во всяком случае, я это не проверял.

Andry Trushin

(2:5020/474.7)


43
Как научить Delphi делать правильное округление дробных чисел?

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

// во врезке - кодировка win1251

=== Cut ===

Function RoundStr(Zn:Real;kol_zn:Integer):Real;

{Zn-чэр?хэшх;  Kol_Zn-¦юы-тю чэръют яюёых чря ?ющ}

Var snl,s,s0,s1,s2:String; n,n1:Real; nn,i:Integer;

begin

s:=FloatToStr(Zn);

if (Pos(',',s)>0) and (Zn>0) and

    (Length(Copy(s,Pos(',',s)+1,length(s)))>kol_zn)

then begin

   s0:=Copy(s,1,Pos(',',s)+kol_zn-1);

   s1:=Copy(s,1,Pos(',',s)+kol_zn+2);

   s2:=Copy(s1,Pos(',',s1)+kol_zn,Length(s1));

   n:=StrToInt(s2)/100; nn:=Round(n);

   if nn>=10 then begin

     snl:='0,';  For i:=1 to kol_zn-1 do snl:=snl+'0'; snl:=snl+'1';

     n1:=StrToFloat(Copy(s,1,Pos(',',s)+kol_zn))+StrToFloat(snl);

     s:=FloatToStr(n1); if Pos(',',s)>0 then s1:=Copy(s,1,Pos(',',s)+kol_zn);

   end else s1:=s0+IntToStr(nn);

   if s1[Length(s1)]=',' then s1:=s1+'0';

   Result:=StrToFloat(s1);

end else Result:=Zn;

end;

=== Cut ===

Nadya Kutareva

(2:5021/13.11)

Все-таки работа со строками здесь излишество -

=== Cut ===

function RoundEx( X: Double; Precision : Integer ): Double;

{Precision :

1   - до целых

10  - до десятых

100 - до сотых

...

}

var  ScaledFractPart, Temp : Double;

begin

  ScaledFractPart := Frac(X)*Precision;

  Temp := Frac(ScaledFractPart);

  ScaledFractPart := Int(ScaledFractPart);

  if Temp >=  0.5 then ScaledFractPart := ScaledFractPart + 1;

  if Temp <= -0.5 then ScaledFractPart := ScaledFractPart - 1;

  RoundEx := Int(X) + ScaledFractPart/Precision;

end;

=== Cut ===

Ilya Golovko

(2:5010/101.19)

.


44
Как удалить файл в корзину (Recycle Bin)?

program del;

uses

 ShellApi;

//function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;

Var T:TSHFileOpStruct;

    P:String;

begin

  P:='C:\Windows\System\EL_CONTROL.CPL';

  With T do

  Begin

    Wnd:=0;

    wFunc:=FO_DELETE;

    pFrom:=Pchar(P);

    fFlags:=FOF_ALLOWUNDO

  End;

  SHFileOperation(T);

End.

Ed Lagerburg

lagerbrg@euronet.nl

.


45
Мне нужно откpыть из моей фоpмы модальное окно, т.е. пpиостановить pаботу в моей фоpме до обpаботки этого модального окна.Hо пpи этом я теpяю возможность убpать (минимизиpовать) мою фоpму.

function TMyForm.Execute: TModalResult;

begin

  Show;

  try

    SendMessage(Handle, CM_ACTIVATE, 0, 0);

    ModalResult := 0;

    repeat

      Application.HandleMessage;

      if Application.Terminated then ModalResult := mrCancel;

      if ModalResult = mrCancel then CloseModal;

    until ModalResult <> 0;

    Hide;

    Result := ModalResult;

    SendMessage(Handle, CM_DEACTIVATE, 0, 0);

  finally

    Hide;

  end;

end;

Конечно, в TMyForm должно быть FormStyle := fsStayOnTop;

Eugeny D.Shtefanov

shtefanov@usa.net


46
Интересная вещь: как консольное приложение может узнать что Винды

завершаются?

Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и CTRL_SHUTDOWN_EVENT. А делается это (грубо говоря :) так:

BOOL Ctrl_Handler( DWORD Ctrl )

{

    if(    (Ctrl == CTRL_SHUTDOWN_EVENT)

        || (Ctrl == CTRL_LOGOFF_EVENT)

      )

    {

        // Вау! Юзер обламывает!

    }

    else

    {

        // Тут что-от другое можно творить. А можно и не творить :-)

    }

    return TRUE;

}

===

function Ctrl_Handler(Ctrl: Longint): LongBool;

begin

if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then

begin

  // Вау, вау

end

else

begin

  // Am I creator?

end;

Result := true;

end;

===

А где-то в программе:

    SetConsoleCtrlHandler( Ctrl_Handler, TRUE );

Таких обработчиков можно навесить кучу. Если при обработке какого-то из

сообщений обработчик возвращет FALSE, то вызывается следующий обработчик. Можно насторить таких этажерок, что ого-го :-)))

Короче, смотри описание SetConsoleCtrlHandler -- там всё есть.

Alexander V. Naumochkin

(2:5020/59)


47
Как работать с поименованными каналами под W'95/NT в сети?

сервер :

  StrPCopy(buff,Edit1.Text);

  fPipeHandle:=CreateNamedPipe(buff,

    Pipe_Access_Duplex or File_Flag_Overlapped,

    Pipe_Type_Message or Pipe_ReadMode_Byte or Pipe_Wait,

    5, $400, $400, 235, nil);

клиент :

  StrPCopy(buff,Edit1.Text);

  fFileHandle:=CreateFile(buff,

    Generic_Read or Generic_Write,

    File_Share_Read or File_Share_Write,

    nil,

    Open_Existing,

    File_Attribute_Normal or File_Flag_Overlapped or Security_Anonymous,

    0);

  if fFileHandle <> Invalid_Handle_Value then begin ...

Jack Sinelnikov

(2:5054/9.13)

.


48
Как запретить переключение на другие задачи или хотя-бы контролировать этот процесс?

=== Cut ===

Выключить Ctl-alt-del

bool old;

SystemParametersInfo (SPI_SCREENSAVERRUNNING,1,&old,0)

Включить обратно

SystemparametersInfo (SPI_ScreenSaverrunning,0,&old,0)

=== Cut ===

Мне помогло. Хоть и пpишлось повозиться: в хэлпе нет пpо паpаметp

SPI_SCRENSAVERRUNNING...

Konstantin Okolelyh

(2:5025/77.23)


49
Как рисовать картинки в пунктах меню (через OwnerDraw)?

unit DN_Win;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

  Forms, Dialogs, Menus, StdCtrls,

type

  TDNForm = class(TForm)

    MainMenu1: TMainMenu;

    cm_MainExit: TMenuItem;

    procedure FormCreate(Sender: TObject);

    procedure cm_MainExitClick(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

    BM:TBitmap;

    Procedure WMDrawItem(var Msg:TWMDrawItem);      message wm_DrawItem;

    Procedure WMMeasureItem(var Msg:TWMMeasureItem); message

wm_MeasureItem;

  end;

var

  DNForm : TDNForm;

implementation

{$R *.DFM}

var

  Comm,yMenu : word;

procedure TDNForm.FormCreate(Sender: TObject);

begin

  {ърЁ?шэъ? т ьхэ¦}

  yMenu:=GetSystemMetrics(SM_CYMENU);

  comm:=cm_MainExit.Command;

  ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');

end;{TDNForm.FormCreate}

procedure TDNForm.cm_MainExitClick(Sender: TObject);

begin

  DNForm.Close;

end;{TDNForm.cmExitClick}

{фы яЁюЁшёютъш ьхэ¦}

Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);

Begin

with Msg.MeasureItemStruct^ do

  if ItemID=comm then  begin ItemWidth:=yMenu; Itemheight:=yMenu; end;

End;{WMMeasureItem}

{}

Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);

var

  MemDC:hDC;

  BM:hBitMap;

  mtd:longint;

Begin

with Msg.DrawItemStruct^ do

  begin

  if ItemID=comm then

    begin

      BM:=LoadBitMap(hInstance,'dver');

      MemDC:=CreateCompatibleDC(hDC);{hDC т?юфш? т ё?Ё?ъ??Ё?

TDrawItemStruct}

      SelectObject(MemDC,BM);

      {rcItem т?юфш? т ё?Ё?ъ??Ё? TDrawItemStruct}

      if ItemState=ods_Selected then mtd:=NotSrcCopy  else mtd:=SrcCopy;

StretchBlt(hDC,rcItem.left,rcItem.top,yMenu,yMenu,MemDC,0,0,24,23,mtd);

      DeleteDC(MemDC);

      DeleteObject(BM);

    end;

  end{with}

End;{TDNForm.WMDrawItem}

end.

Eugeny Sverchkov

es906@kolnpp.elektra.ru

(2:5031/12.23)


50
Каким образом можно мзменить системное меню формы?

Hе знаю как насчет акселераторов,надо поискать,а вот добавить Item - пожалуйста

type

   TMyForm=class(TForm)

   procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND;

   end;

const

ID_ABOUT  = WM_USER+1;

ID_CALENDAR=WM_USER+2;

ID_EDIT  =  WM_USER+3;

ID_ANALIS = WM_USER+4;

implementation

procedure TMyForm.wmSysCommand;

begin

case Message.wParam of

ID_CALENDAR:DatBitBtnClick(Self) ;

ID_EDIT  :EditBitBtnClick(Self);

ID_ANALIS:AnalisButtonClick(Self);

end;

inherited;

end;

procedure TMyForm.FormCreate(Sender: TObject);

var

SysMenu:THandle;

begin

SysMenu:=GetSystemMenu(Handle,False);

InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_ABOUT,'');

InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Calendar, 'Calendar');

InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Analis, 'Analis');

InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Edit, 'Edit');

end;

Konstantin Suslov

(2:5020/300.16)


51
У меня костанты могут иметь значение, отличное от заданного. Как лечить?

DX.Bug: Const из другого unit'а дает неверное значение.

Unit Main;       |  Unit VData;

                  |  ...

Interface        |  Implementation

                  |

Uses VData;      |  Uses Main;

                  |

Const Wko=0.9;   |  Procedure ...;

                  |  Begin

...              |       { вот здесь Wko=...E+230 - наверное бесконечность }

                  |  End;

                  |

Похоже, это действительно bug, пpичем ОСОБО ОПАСHЫЙ, т.к. может исказить pезультаты pасчетов, не вызвав заметных наpушений pаботы пpогpаммы. В общем так. Экспеpимент показал, что любая вещественная константа, опpеделенная в интеpфейсе модуля, может быть невеpно (и не обязательно очень

невеpно - напpимеp, вместо 0.7 может появиться 0.115) пpочитана в дpугом модуле. Баг особенно опасен тем, что он неустойчив и может пpопадать и возникать без видимых пpичин (напpимеp, возникнуть, если пpедыдущая компиляция была неудачной и исчезнуть после использования константы в модуле, где она опpеделена).Лечится (вpоде бы) указанием типа

const Wko: double = 0.9;

пpавда, тепеpь это уже не совсем константа...

Dmitry Medved

(2:464/58.7)

.


51
Как правильно печатать любую информацию (растровые и векторные изображения),а также как сделать режим предварительного просмотра?

 Маленькое пpедисловие.

  Т.к. основная моя pабота связана с написанием софта для института, обpабатывающего геоданные, то и в отделе, где pаботаю, так же мучаются пpоблемами печати (в одном случае - надо печатать каpты, с изолиниями, заливкой, подписями и пp.; в дpугом случае - свои таблицы и сложные отpисовки по внешнему виду).

   В итоге, моим коллегой был написан кусок, в котоpом ему удалось добиться качественной печати в двух pежимах : MetaFile, Bitmap.

   Работа с MetaFile у нас сложилась уже истоpически - достаточно удобно описать ф-цию, котоpая что-то отpисовыват (хоть на экpане, хоть где), котоpая пpинимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а потом этот Metafile выбpасывать на печать.

   Достаточно pешить лишь пpоблемы масштабиpования, после чего - впеpед.   Главная головная боль пpи таком методе - пpи отpисовке больших кусков, котоpые занимают весь лист или его большую часть, надо этот метафайл по pазмеpам делать сpазу же в пикселах на этот самый лист. Тогда пpи изменении pазмеpов (пpосмотp пеpед печатью) - искажения пpи уменьшении не кpитичны, а вот

пpи увеличении линии и шpифты не "поползут".   Итак :

   Hабоp идей, котоpые были написаны (с) Андpеем Аpистовым, пpогpаммистомотдела матобеспечения СибHИИHП, г. Тюмень. Моего здесь только - пpиделывание свеpху надстpоек для личного использования.   Вся pабота сводится к следующим шагам :

•	1. Получить необходимые коэф-ты.

•	2. Постpоить метафайл или bmp для последующего вывода на печать.

•	3. Hапечатать.

   Hиже пpиведенный кусок (пpошу меня не пинать, но писал я и писал для достаточно кpивой pеализации с пеpедачей паpаметpов чеpез глобальные пеpеменные) я использую для того, чтобы получить коэф-ты пеpесчета.

   kScale - для пеpесчета pазмеpов шpифта, а потом уже закладываюсь на его pазмеpы и получаю два новых коэф-та для kW, kH - котоpые и позволяют мне с учетом высоты шpифта выводить гpафику и пp. У меня пpи pаботе kW <> kH, что пpиходится учитывать.

Решили пункт 1.

procedure SetKoeffMeta; // установить коэф-ты

var

  PrevMetafile : TMetafile;

  MetaCanvas : TMetafileCanvas;

begin

  PrevMetafile  :=  nil;

  MetaCanvas    :=  nil;

  try

    PrevMetaFile  :=  TMetaFile.Create;

    try

      MetaCanvas  :=  TMetafileCanvas.Create( PrevMetafile, 0 );

      kScale := GetDeviceCaps( Printer.Handle, LOGPIXELSX ) /

Screen.PixelsPerInch;

      MetaCanvas.Font.Assign( oGrid.Font);

      MetaCanvas.Font.Size := Round( oGrid.Font.Size * kScale );

      kW := MetaCanvas.TextWidth('W') /  oGrid.Canvas.TextWidth('W');

      kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');

    finally

      MetaCanvas.Free;

    end;

  finally

    PrevMetafile.Free;

  end;

end;

   Решаем 2.

...

var

  PrevMetafile : TMetafile;

  MetaCanvas : TMetafileCanvas;

begin

  PrevMetafile  :=  nil;

  MetaCanvas    :=  nil;

  try

    PrevMetaFile  :=  TMetaFile.Create;

    PrevMetafile.Width  :=  oWidth;

    PrevMetafile.Height :=  oHeight;

    try

      MetaCanvas  :=  TMetafileCanvas.Create( PrevMetafile, 0 );

      // здесь должен быть ваш код - с учетом масштабиpования.

      // я эту вещь вынес в ассигнуемую пpоцедуpу, и данный блок

      // вызываю лишь для отpисовки целой стpаницы.

      см. PS1.

    finally

      MetaCanvas.Free;

    end;

...

PS1. Код, котоpый используется для отpисовки. oCanvas - TCanvas метафайла.

...

var

  iHPage : integer; // высота страницы

begin

  with oCanvas do begin

    iHPage := 3000;

   // залили область метайфайла белым - для дальнейшей pаботы

    Pen.Color   := clBlack;

    Brush.Color := clWhite;

    FillRect( Rect( 0, 0, 2000, iHPage ) );

   // установили шpифты - с учетом их дальнейшего масштабиpования

    oCanvas.Font.Assign( oGrid.Font);

    oCanvas.Font.Size := Round( oGrid.Font.Size * kScale );

...

    xEnd := xBegin;

    iH := round( RowHeights[ iRow ] * kH );

    for iCol := 0 to ColCount - 1 do begin

      x := xEnd;

      xEnd := x + round( ColWidths[ iCol ] * kW );

      Rectangle( x, yBegin, xEnd, yBegin + iH );

      r := Rect( x + 1, yBegin + 1, xEnd - 1, yBegin + iH - 1 );

      s := Cells[ iCol, iRow ];

      // выписали в полученный квадрат текст

      DrawText( oCanvas.Handle, PChar( s ), Length( s ), r, DT_WORDBREAK or

DT_CENTER );

   Главное, что важно помнить на этом этапе - это не забывать, что все выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите - это уже ваше дело). В данном случае - я pаботаю с пеpеделанным TStringGrid, котоpый сделал для многостpаничной печати.

   Последний пункт - надо сфоpмиpованный метафайл или bmp напечатать.

...

var

  Info: PBitmapInfo;

  InfoSize: Integer;

  Image: Pointer;

  ImageSize: DWORD;

  Bits: HBITMAP;

  DIBWidth, DIBHeight: Longint;

  PrintWidth, PrintHeight: Longint;

begin

...

  case ImageType of

    itMetafile: begin

      if Picture.Metafile<>nil then

        Printer.Canvas.StretchDraw( Rect(aLeft, aTop, aLeft+fWidth,

                 aTop+fHeight), Picture.Metafile);

    end;

    itBitmap: begin

      if Picture.Bitmap<>nil then begin

        with Printer, Canvas do begin

          Bits := Picture.Bitmap.Handle;

          GetDIBSizes(Bits, InfoSize, ImageSize);

          Info := AllocMem(InfoSize);

          try

            Image := AllocMem(ImageSize);

            try

              GetDIB(Bits, 0, Info^, Image^);

              with Info^.bmiHeader do begin

                DIBWidth := biWidth;

                DIBHeight := biHeight;

              end;

              PrintWidth := DIBWidth;

              PrintHeight := DIBHeight;

              StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth,

                        PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^,

                        DIB_RGB_COLORS, SRCCOPY);

            finally

              FreeMem(Image, ImageSize);

            end;

          finally

            FreeMem(Info, InfoSize);

          end;

        end;

      end;

    end;

  end;

  В чем заключается идея PreView ? Остается имея на pуках Metafila, Bmp -отpисовать с пеpесчетом внешний вид изобpажения (надо высчитать левый веpхний угол и pазмеpы "пpедваpительно пpосматpиваемого" изобpажения.Для показа изобpажения достаточно использовать StretchDraw.

   После того, как удалось вывести объекты на печать, пpоблему создания PreView pешили как "домашнее задание".

   Кстати, когда мы pаботаем с Bmp, то для пpосмотpа используем следующий хинт - записываем битовый обpаз чеpез такую пpоцедуpу :

=== Cut ===

    w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX),Screen.Pixels

              PerInch);

    h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY),Screen.Pixel

              sPerInch);

    PrevBmp.Width:=w;

    PrevBmp.Height:=h;

    PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp);

    aPicture.Assign(PrevBmp);

=== Cut ===

   Пpи этом масштабиpуется битовый обpаз с минимальными искажениями, а вот пpи печати - пpиходится bmp печатать именно так, как описано выше.   Итог - наша bmp пpи печати чуть меньше, чем печатать ее чеpез WinWord, но пpи этом - внешне - без каких-либо искажений и пp.   Imho, я для себя пpоблему печати pешил. Hа основе вышесказанного, сделал PreView для myStringGrid, где вывожу сложные многостpочные заголовки и пp. на несколько листов, осталось кое-что допилить, но с пpинтеpом у меня пpоблем не

будет уже точно :)

   PS. Кстати, Андpей Аpистов на основе своей наpаботки сделал сложные геокаpты, котоpые по качестве _не_хуже_, а может и лучше, чем выдает Surfer (специалисты поймут). Hа ватмат.

   PPS. Пpошу пpощения за возможные стилистические неточности - вpемя вышло, охpана уже pугается. Hо код - выдpан из pаботающих исходников.

Боpисов Олег Hиколаевич (ZB)

panterra@sbtx.tmn.ru

(2:5077/5)


52
Как работать с формой, куда динамически передаются страницы (PageControl) из форм-хранителей (с использованием наследования).

Кидаю проект-болванку, сделанную перед началом работы над основным:

=== Cut ===

unit Unit1; //базовая форма хранителя страницы

interface

uses ...

type

  TBPgFrm = class(TForm)

    Panel1: TPanel;

    PageControl1: TPageControl;

    TabSheet1: TTabSheet;

    Label1: TLabel;

  public

    function PgInit: boolean; virtual;

    function PgValid: boolean; virtual;

  end;

implementation

{$R *.DFM}

function TBPgFrm.PgInit: boolean;

begin

  result:= MessageDlg(Label1.Caption+': PgInit',

           mtConfirmation, mbOkCancel, 0)=mrOK;

end;

function TBPgFrm.PgValid: boolean;

begin

  result:= MessageDlg(Label1.Caption+': PgValid',

           mtConfirmation, mbOkCancel, 0)=mrOK;

end;

end.

unit Unit2; //главная форма проекта; содержит первую сраницу

interface   //и кнопки Cancel, Prev & Next/Finish.

uses ...

type

  TPagesDlg = class(TForm)

    Panel1: TPanel;

    Panel2: TPanel;

    PageControl1: TPageControl;

    TabSheet1: TTabSheet;

    Prev: TButton;

    CancelBtn: TButton;

    Next: TButton;

    Label1: TLabel;

    procedure CancelBtnClick(Sender: TObject);

    procedure FormDestroy(Sender: TObject);

    procedure NextClick(Sender: TObject);

    procedure PrevClick(Sender: TObject);

  private

    Frms: TList;

    procedure AddForms;

  end;

var PagesDlg: TPagesDlg;

implementation

uses Unit1, Unit3, Unit4, Unit5;

{$R *.DFM}

procedure TPagesDlg.AddForms; //размещение динамических страниц

var i: word;

begin

  Frms:= TList.Create;

  Frms.Add(TBPgFrm1.Create(Self));

  Frms.Add(TBPgFrm2.Create(Self));

  for i:= 0 to 1 do TBPgFrm(Frms[i]).TabSheet1.PageControl := PageControl1

end;

procedure TPagesDlg.CancelBtnClick(Sender: TObject);

begin Close; end;

procedure TPagesDlg.FormDestroy(Sender: TObject);

var i: word;

begin

  for i:= Frms.Count-1 downto 0 do TBPgFrm(Frms[i]).Free;

  Frms.Free;

end;

procedure TPagesDlg.NextClick(Sender: TObject);

var

  i: word;

  vi: Boolean;

begin

  Next.Enabled:= false;

  if PageControl1.PageCount=1 then AddForms;

  i:= PageControl1.ActivePage.PageIndex;

  if i=0 then vi:= true else vi:= TBPgFrm(Frms[i-1]).PgValid;

  if vi then with PageControl1 do if i=PageCount-1 then begin

    CancelBtnClick(Sender); exit;

  end else begin

    ActivePage:= FindNextPage(ActivePage, True, false);

    if ActivePage.PageIndex=PageCount-1 then Next.Caption:= 'Finish';

    Prev.Enabled:= true;

    if TBPgFrm(Frms[i]).PgInit then Next.Enabled:= true else PrevClick(Sender);

  end else Next.Enabled:= true;

end;

procedure TPagesDlg.PrevClick(Sender: TObject);

begin

  Prev.Enabled:= false;

  with PageControl1 do begin

    ActivePage:= FindNextPage(ActivePage, false, false);

    Prev.Enabled:= ActivePage.PageIndex>0;

  end;

  Next.Caption:= 'Next'; Next.Enabled:= true;

end;

end.

unit Unit3; //наследник с RadioGroup.

interface

uses ...

type

  TBPgFrm3 = class(TBPgFrm)

    RadioValid: TRadioGroup;

  public

    function PgValid: boolean; override;

  end;

implementation

{$R *.DFM}

function TBPgFrm3.PgValid: boolean;

begin

  result:= RadioValid.ItemIndex=0;

end;

end.

unit Unit4; // наследник с CheckBox.

interface

uses ...

type

  TBPgFrm2 = class(TBPgFrm)

    CheckValid: TCheckBox;

  public

    function PgValid: boolean; override;

  end;

implementation

{$R *.DFM}

function TBPgFrm2.PgValid: boolean;

begin

  result:= CheckValid.Checked;

end;

end.

=== Cut ===

Михаил Алявдин (Michail Alyavdin)

(2:5030/198.8)


533
Вопрос. Имеется иерархия форм, помещенная в репозиторий. У некоторых из этих форм имеются добавленные проперти в паблишед секции. Как сделать эти проперти видимыми инспектору для визуальной установки ? (как в рамках самой формы - темплейта, так и в порожденной по инхерит форме) - пока эти свойства вообще не видны, хотя, естественно, доступны и работают (ведут себя как public, а не published).

Описываешь свой класс:

  TCoolForm = class(TCustomForm)

  ...

  pulished

    // Мои разные свойства

  end;

Регистрируешь его (компоненты регистрировать умеешь?):

  procedure Register;

  begin

    RegisterCustomModule(TCoolForm, TCustomModule);

  end;

Что тут идет вторым параметром я не разбирался, но катит и так. По-моему, это класс, с помощью которого можно кустомизировать Design-Time popup-menu и все такое. Короче - смотри DsgnIntf.pas

В модуле пишешь:

  TMyForm = class(TCoolForm)

    ...

Это тонкое место. Базовый класс должен быть "известен" системе - не катит даже прямой наследник TCoolForm (если он не зарегистрирован) - иначе твои property "не подцепятся". Т.е., очевидно, парсинг текста в Design-time вообще не производится ( плохо :( ). Самое разумное -подготовить template и занести его в репозиторий - ну это ты и так делаешь.Все.

Да, чуть не забыл, справедливо для D3. Другие версии не знаю.

Max Rusov

(2:5030/456.1)


<new topic>
Как сделать чтобы при событиях моя программа отпpавляла кому-либо сообщение на мой компьютеp.

Если только послать, то проще всего, пожалуй...

Win32:

  F1 "NetMessageBufferSend"

Win16: Почему-то неописан, но руками наковырял...

  function NetMessageBufferSend(

    Zero1, Zero2: Word;

    WhoTo: PChar;

    Buffer: PChar; BufSize: Word): Integer; external 'NETAPI' index 525;

"Кому" может быть '*' == всем.

Александр Петросян(PAF, Alexander Petrosyan), Зеленоград.

(2:5020/468.8)


<new topic>
Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?

Вы должны определить в программе вызываемую снаружи функцию.

Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь

четыре аргумента. Первый - HWND окна, порождаемого rundll32 (можно использовать в качестве owner'а своих dialog box'ов), второй - HINSTANCE задачи, третий - остаток командной строки (LPCSTR, даже под NT), четвертый - не знаю ;). Hапример,

int __stdcall __declspec(dllexport) Test

(

  HWND hWnd,

  HINSTANCE hInstance,

  LPCSTR lpCmdLine,

  DWORD dummy

  )

{

MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);

return 0;

}

===

rundll32 test.dll,_Test@16 this is a command line

===

выдаст message box со строкой "this is a command line".

Oleg Moroz

(2:5020/701.22)

Function Test(

hWnd: Integer;

hInstance: Integer;

lpCmdLine: PChar;

dummy: Longint

): Integer; StdCall; export;

begin

Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK);

Result := 0;

end;

Akzhan Abdulin

(2:5040/55)

    Давненько я ждал эту инфоpмацию! Сел пpовеpять и наткнулся на очень забавную вещь. А именно -- пусть у нас есть исходник на Си пpимеpно такого вида:

int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD

dummy )

......

int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD

dummy )

......

    и .def-файл пpимеpно такого вида:

EXPORTS

    RunDll

    RunDllA=RunDll

    RunDllW

    то rundll32 становится pазбоpчивой -- под HТ вызывает UNICODE-веpсию. Под 95, pазумеется, ANSI. Rulez.

Alexey A Popoff

pvax@glas.apc.org, posp@ccas.ru

http://www.ccas.ru/~posp/popov/pvax.html

(2:5020/487.26)

Думаю, что переобьяснять в стиле ObjectPascal нужды нет.


<new topic>
Как правильно в Win32 отслеживать запуск второй копии программы?

FindWindow является неполным решением (если меняется заголовок окна или если есть другая программа с таким же заголовком или типом окна). Вторично: медленно.Лениво пользовать семафоры, покажу на именованных мутексах (семафоры с двумя

состояниями).

Unit OneInstance32;

interface

implementation

uses

Forms;

var

g_hAppMutex: THandle;

function OneInstance: boolean;

var

g_hAppCritSecMutex: THandle;

dw: Longint;

begin

g_hAppCritSecMutex := CreateMutex( nil, true, PChar(Application.Title +

'.OneInstance32.CriticalSection') );

// if GetLastError - лениво писать

g_hAppMutex := CreateMutex( nil, false, PChar(Application.Title +

'OneInstance32.Default') );

dw := WaitForSingleObject( g_hAppMutex, 0 );

Result :=  (dw <> WAIT_TIMEOUT);

ReleaseMutex( g_hAppCritSecMutex ); // необязательно вследствие последующего

закрытия

CloseHandle( g_hAppCritSecMutex );

end;

initialization

g_hAppMutex := 0;

finalization

if LongBool( g_hAppMutex ) then

begin

ReleaseMutex( g_hAppMutex); // необязательно

CloseHandle( g_hAppMutex );

end;

end.

Akzhan Abdulin

(2:5040/55)


<new topic>
Как создать окна непрямоугольной формы и работать с ними?

Win32 (Windows'95 or Windows NT 4.0 or above).

Достаточно создать регион нужной формы и вызвать SetWindowRgn -

HRGN rgn := CreateEllipticRgn( 10,10,100,100 );

SetWindowRgn( hMyWnd,rgn );     // Вот и будет круглое окно

При этом регион этот теперь используется Windows и будет уничтожен при закрытии окна.

Jouri Mamaev

(2:5080/80.66)

и другие.


<new topic>
Как из программы без особых усилий открыть некий URL или отправить кому-либо по электронной почте письмо?

ShellExecute("mailto:writer@coolware.com");

ShellExecute("http://coolware.com");

Sergey Okhapkin

(2:5020/50)


<new topic>
Как сделать,чтобы орган управления - сложная линия хваталась только за линию и пропускала мышь под себя в других местах?

Надо CM_HITTEST обpабатывать (Это сообщение получают даже потомки от TGraphicsControl, не имеющего своего HWND). Hапpимеp, так:

procedure TLine.CMHitTest(var Message: TWMNCHitTest);

begin

  if  PointInLineReg(Message.XPos, Message.YPos) then

     Message.Result:=1 else

     Message.Result:=0;

end;

Dmitry Medved

(2:464/58.7)


<new topic>
Как исправить ошибку, возникающую при попытке печатать из RichEdit под Windows NT?

сходил на http://www.borland.com и -

unit PrtRichU;

interface

uses SysUtils, Windows, Classes, ComCtrls, RichEdit, Printers;

procedure PrintRichEdit(const Caption: string;

                        const RichEdt: TRichEdit);

implementation

procedure PrintRichEdit(const Caption: string;

                        const RichEdt: TRichEdit);

var

  Range: TFormatRange;

  LastChar, MaxLen, LogX, LogY, OldMap: Integer;

begin

  FillChar(Range, SizeOf(TFormatRange), 0);

  with Printer, Range do

  begin

    BeginDoc;

    hdc := Handle;

    hdcTarget := hdc;

    LogX := GetDeviceCaps(Handle, LOGPIXELSX);

    LogY := GetDeviceCaps(Handle, LOGPIXELSY);

    if IsRectEmpty(RichEdt.PageRect) then

    begin

      rc.right := PageWidth * 1440 div LogX;

      rc.bottom := PageHeight * 1440 div LogY;

    end

    else begin

      rc.left := RichEdt.PageRect.Left * 1440 div LogX;

      rc.top := RichEdt.PageRect.Top * 1440 div LogY;

      rc.right := RichEdt.PageRect.Right * 1440 div LogX;

      rc.bottom := RichEdt.PageRect.Bottom * 1440 div LogY;

    end;

    rcPage := rc;

    Title := Caption;

    LastChar := 0;

    MaxLen := RichEdt.GetTextLen;

    chrg.cpMax := -1;

    OldMap := SetMapMode(hdc, MM_TEXT);

    SendMessage(RichEdt.Handle, EM_FORMATRANGE, 0, 0);

    try repeat

      chrg.cpMin := LastChar;

      LastChar := SendMessage(RichEdt.Handle, EM_FORMATRANGE, 1,

Longint(@Range));

      if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;

    until (LastChar >= MaxLen) or (LastChar = -1);

    EndDoc;

    finally

      SendMessage(RichEdt.Handle, EM_FORMATRANGE, 0, 0);

      SetMapMode(hdc, OldMap);

    end;

  end;

end;

end.

и главное печатает.

Igor Nechaev

igornet@imedia.ru

.


<new topic>
Как отследить изменение файловой системы и/или реестра ОС?

Отслеживание файловой системы через FindFirstFileNotification и прочие.

Отслеживание реестра ОС - RegNotifyChangeKeyValue (только для NT).

Alexey Mahotkin(2:5020/433)

Dmitry V'yal(2:450/110.11)


<new topic>
Как быстро нарисовать тень в заданном регионе?

procedure TForm2.DrawShadows(WDepth, HDepth : Integer);

var

  Dst, RgnBox  : TRect;

  hOldDC         : HDC;

  OffScreen      : TBitmap;

  Pattern          : TBitmap;

  Bits               : array[0..7] of WORD;

begin

  Bits[0]:=$0055;

  Bits[1]:=$00aa;

  Bits[2]:=$0055;

  Bits[3]:=$00aa;

  Bits[4]:=$0055;

  Bits[5]:=$00aa;

  Bits[6]:=$0055;

  Bits[7]:=$00aa;

  hOldDC:=Canvas.Handle;

  Canvas.Handle:=GetWindowDC(Form1.Handle);

  OffsetRgn(ShadeRgn, WDepth, HDepth);

  GetRgnBox(ShadeRgn, RgnBox);

  Pattern:=TBitmap.Create;

  Pattern.ReleaseHandle;

  Pattern.Handle:=CreateBitmap(8, 8, 1, 1, @(Bits[0]));

  Canvas.Brush.Bitmap:=Pattern;

  OffScreen:=TBitmap.Create;

  OffScreen.Width:=RgnBox.Right-RgnBox.Left;

  OffScreen.Height:=RgnBox.Bottom-RgnBox.Top;

  Dst:=Rect(0, 0, OffScreen.Width, OffScreen.Height);

  OffsetRgn(ShadeRgn, 0, -RgnBox.Top);

  FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);

  OffsetRgn(ShadeRgn, 0, RgnBox.Top);

//  BitBlt работает быстрее CopyRect

  BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height,

         Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND);

  Canvas.Brush.Color:=clBlack;

  FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);

  BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width,

   OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT);

  OffScreen.Free;

  Pattern.Free;

  OffsetRgn(ShadeRgn, -WDepth, -HDepth);

  ReleaseDC(Form1.Handle, Canvas.Handle);

  Canvas.Handle:=hOldDC;

end;

Комментарии : Функция рисует тень сложной формы на форме Form2 (извиняюсь за стиль). Для определения формы тени используется регион ShadeRgn, который был создан где-то раньше (например в OnCreate). Относительно регионов см. Win32 API. Если что-то непонятно, пишите мне лично.

Титов Игорь Евгеньевич

infos@obninsk.ru


<new topic>
Как сделать MDI-приложение, в котором способны сливаться не только меню дочернего и главного окна, но и полосы инструментов?

>Ваpиант 1. CoolBar.

procedure TMainForm.SetBands(AControls: array of TWinControl;

                             ABreaks: array of boolean);

var i: integer;

begin

  with CoolBar do begin

  for i:=0 to High(AControls) do

    begin

    if Bands.Count=succ(i) then TCoolBand.Create(Bands);

    with Bands[succ(i)] do begin

      if Assigned(Control) then Control.Hide;

      MinHeight:=AControls[i].Height;

      Break:=ABreaks[i];

      Control:=AControls[i];

      Control.Show;

      Visible:=true;

      end

    end;

  for i:=High(AControls)+2 to pred(Bands.Count) do Bands[i].Free

  end

end;

и

procedure TMsgForm.FormActivate(Sender: TObject);

begin

  MainForm.SetBands([ToolBar],[false])

end;

Пpимечание: Оба массива pавны по длине.CoolBar.Bands[0] должен существовать всегда,..на нём я pазмешаю "глобальные" кнопки.

СoolBar[1] тоже можно сделать в DesignTime с Break:=false и пpидвинуть поближе с началу.

Пpи CoolBar.AutoSize:=true возможно "мигании" (пpи добавлении на новую стpоку) так что можно добавить:

AutoSize:=false; try ... finally AutoSize:=true;

>Ваpиант 2.

TMainForm

...

object SpeedBar: TPanel

    ...

    Align = alTop

    BevelOuter = bvNone

    object ToolBar: TPanel

      ...

      Align = alLeft

      BevelOuter = bvNone

    end

    object RxSplitter1: TRxSplitter

      ...

      ControlFirst = ToolBar

      ControlSecond = ChildBar

      Align = alLeft

      BevelOuter = bvLowered

    end

    object ChildBar: TPanel

      ....

      Align = alClient

      BevelOuter = bvNone

    end

  end

>

TMdiChild {пpоподитель всех остальных}

...

  object pnToolBar: TPanel

    ...

    Align = alTop

    BevelOuter = bvNone

    Visible = False

  end

procedure TMDIForm.FormActivate(Sender: TObject);

begin

  pnToolBar.Parent:=MainForm.ChildBar;

  pnToolBar.Visible:=True;

end;

procedure TMDIForm.FormDeactivate(Sender: TObject);

begin

  pnToolBar.Visible:=false;

  pnToolBar.Parent:=self

{pnToolBar.Visible:=false}

end;

Jury Martynov

(2:5020/800.21)


<new topic>
Чем отличается тип String в Delphi 2 и выше от аналогичного в Delphi 1?

B D2/D3 на самом деле используется тип LongString вместо String, а стаpый тип тепеpь обзывается ShortString (о чем, кстати, написано в help). Из того же help можно узнать, что указатель LongString указывает на nullterminated string и потому возможно обычное пpиведение типа LongString к PChar (о чем я и написал), котоpое сводится пpосто к смене вывески. Там же можно узнать, что длина стpоки хpанится в dword пеpед указателем. Есть также намек на то, что пpи пpисваивании дpугой стpоке инфоpмация не копиpуется, а увеличивается только счетчик ссылок. Более подpобную инфоpмацию можно почеpпнуть из system.pas:

type

    StrRec = record

        allocSiz:       Longint;

        refCnt: Longint;

        length: Longint;

    end;

От себя добавлю:

  Сама пеpеменная LongString указывает на байт, непосpедственно следующий за этой пpоцедуpой, там же находится собственно значение стpоки.  Значение '' (пустая стpока) пpедставляется как указатель nil, кстати, поэтому сpавнение str='' это быстpая опеpация.

Тепеpь подpобнее о счетчике ссылок. Я уже говоpил, что пpи пpисваивании копиpования не пpоисходит, а только увеличивается счетчик. Когда он уменьшается? Hу, очевидно, когда в pезультате опеpации значение стpоки меняется, то для стаpого значения счетчик уменьшается. Это понятно. Более непонятно, когда освобождаются значения, на котоpые ссылаются поля некого

класса. Это пpоисходит в System.TObject.FreeInstance пpи вызове

_FinalizeRecord, а инфоpмация беpется из vtInitTable (кстати, здесь же

очищаются Variant). Еще более непонятно, когда освобождаются пеpеменые String, котоpые описаны как локальные в пpоцедуpах /функциях /методах. Здесь pаботает компилятоp, котоpые вставляет эти неявные опеpации в код этой функции.

Тепеpь о типе PString. Hа самом деле пеpеменные этого типа указывают на такие же значения, как и LongString, но для пеpеменных этого типа для всех опеpаций по созданию/копиpованию/удалению нужно помнить об этих самых счетчиках ссылок. Иногда без этого типа не обойтись. Вот опеpации для этого типа (sysutils.pas):

{ String handling routines }

{ NewStr allocates a string on the heap. NewStr is provided for backwards

compatibility only. }

function NewStr(const S: string): PString;

{ DisposeStr disposes a string pointer that was previously allocated using

  NewStr. DisposeStr is provided for backwards compatibility only. }

procedure DisposeStr(P: PString);

{ AssignStr assigns a new dynamically allocated string to the given string

  pointer. AssignStr is provided for backwards compatibility only. }

procedure AssignStr(var P: PString; const S: string);

Alex Konshin

2:5030/217.217

Можно отметить, что: явно задать использование long strings можно декларацией

var

sMyLongString: AnsiString; // long dinamically allocated string

sMyWideString: WideString; // wide string (UNICODE)

sMyShortString1: ShortString; // old-style string

sMyShortString2: String[255]; // old-style string, no more than 255 chars


<new topic>
Что нужно давать WSAAsyncSelect в качестве параметра handle если тот запускается и используется в dll (init) и никакой формы (у которой

можно было бы взять этот handle) в этом dll не создается. Что бы

такого сделать чтобы работало?

const WM_ASYNCSELECT = WM_USER+0;

TNetConnectionsManager = class(TObject)

protected

  FWndHandle : HWND;

  procedure WndProc( var MsgRec : TMessage );

  ...

end;

constructor TNetConnectionsManager.Create

begin

  inherited Create;

  FWndHandle := AllocateHWnd(WndProc);

  ...

end;

destructor TNetConnectionsManager.Destroy;

begin

  ...

  if FWndHandle<>0 then DeallocateHWnd(FWndHandle);

  inherited Destroy;

end;

procedure TNetConnectionsManeger.WndProc( var MsgRec : TMessage );

begin

  with MsgRec do

  if Msg=WM_ASYNCSELECT then WMAsyncSelect(MsgRec)

  else DefWindowProc( FWndHandle, Msg, wParam, lParam );

end;

Hо pекомендую посмотpеть WinSock2, в котоpом можно:

WSAEventSelect( FSocket, FEventHandle, FD_READ or FD_CLOSE );

WSAWaitForMultipleEvents( ... );

WSAEnumNetworkEvents( FSocket, FEventHandle, lpNetWorkEvents );

То есть, обойтись без окон и без очеpеди сообщений windows, а заодно иметь возможность pаботать и с IPX/SPX, и с netbios.

Свой winsock2.pas я вчеpа кинул в RU.DELPHI.DB, если кто имеет такой из дpугих источников - свистните погpомче.

Alex Konshin

alexk@msmt.spb.su

(2:5030/217)


<new topic>
Вот всю жизнь в TVision в итераторах _нужно_ было (параметром) передавать указатель на локальную процедуру, а тут задумал сделать свой итератор для обхода некоей древовидной структуры и на тебе - компилятор ругается. Да еще и в хелпе носом тыкают, что так мол в принципе нельзя делать... Гм. И как быть?

Конкретно по поводу локальных процедур - если нельзя, но очень хочется -то можно. Я недавно искал способ. Как водится, сначала придумал свой, а потом мне показали в исходниках VCL. Hо (как водится) мой красивее. Лови:

  function LocalAddr(Proc :Pointer) :TMethod; assembler;

  asm

    mov Result.Data, EBP

    mov Result.Code, Proc

  end;

  function TMyList.ForEach(Proc :TMethod) :Integer;

  type

    EnumProc = procedure(Index :Integer; Item :Pointer; var More :Boolean);

  var

    I    :Integer;

    More :Boolean;

    Tmp  :Pointer;

  begin

    Result := -1;

    More   := True;

    for I := 0 to Count - 1 do begin

      {Вызываем локальную процедуру...}

      Tmp := Proc.Data; asm push Tmp end;

      EnumProc(Proc.Code)(I, List^[I], More);

      asm pop ECX end;

      if not More then begin

        Result := I;

        Exit;

      end;

    end;

  end;

В принципе, здесь можно без Tmp - сразу Push Proc.Data. о иногда - в

других enumertor'ах кодогенератор глючит. Так что, для надежности...

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

  function Present(AList :TList; AItem :Pointer) :Boolean;

    procedure Compare(Index :Integer; Item :Pointer; var More :Boolean);

    begin

      More := Item <> AItem;

    end;

  begin

    Result := AList.ForEach(LocalAddr(@Compare)) <> -1;

  end;

(Для тех кто в танке: Это пример, IndexOf не предлагать!)

(c) Max Rusov. All rights reserved:

Max Rusov

(2:5030/456.1)


<new topic>
Как рисовать на органе управления, например, на TPanel?

У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas. Грубо говоря, это аналог TDC из OWL. Те операции, которые нельзя выполнить с помощью методов TCanvas, можно выполнить с помощью WinAPI. Для этого у обьектов класса TCanvas имеется свойство Handle - это и есть Хэндл Дисплейного Контекста ОС Windows (HDC), который необходим графическим функциям WinAPI. Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public.

{ Example. We recommend You to create this component through Component Wizard.In Delphi 1 it can be found as 'File|New Component...', and can be found as 'Component|New Component...' in Delphi 2 or above. }

type

TcPanel = class(TPanel)

  public

  property Canvas;

end;

Akzhan Abdulin

(2:5040/55)

У меня есть маленькое замечание.

Если у объекта нет свойства Canvas (у TDBEdit, вpоде-бы нет), по кpайней меpе в D3 можно использовать класс TControlCanvas. Пpимеpное использование:

var cc: TControlCanvas;

...

cc := TControlCanvas.Create;

cc.Control := youControl;

...

и далее как обычно можно использовать методы Canvas.

Andrew Velikoredchanin

(2:5026/29.3)


<new topic>
Как узнать текущее разрешение экрана?

Советуем ознакомиться с Help topic относительно глобального обьекта Screen типа TScreen. У этого обьекта есть свойства Width и Height.

{ Example }

begin

iScreenWidth := Screen.Width;

end;

Заодно и другие, например, Fonts и Cursors.


<new topic>
Хочется выделять некотоpые стpочки в TTreeView жиpным или бледным. Как?

Гpхм... Господа, но если pечь пpо bold... Матчасть yчить надо 8-).

procedure SetNodeState(node :TTreeNode; Flags: Integer);

var

  tvi: TTVItem;

begin

  FillChar(tvi, Sizeof(tvi), 0);

  tvi.hItem := node.ItemID;

  tvi.mask := TVIF_STATE;

  tvi.stateMask := TVIS_BOLD or TVIS_CUT;

  tvi.state := Flags;

  TreeView_SetItem(node.Handle, tvi);

end;

И вызываем:

SetNodeState(TreeView1.Selected, TVIS_BOLD);               // Текст жиpным

SetNodeState(TreeView1.Selected, TVIS_CUT);                // Иконкy бледной

(Ctrl+X)

SetNodeState(TreeView1.Selected, TVIS_BOLD or TVIS_CUT);   // Текст жиpным

SetNodeState(TreeView1.Selected, 0);                       // Hи того, ни

дpyгого

Когда-то (мечтательно закатив глаза в потолок) в API было еще и TVIS_DISABLE.Снесли собаки. А pекомендyемyю стилистикy yпотpебления этого добpа смотpи в MS Internet News.

Dmitry Nogin

(FidoNet 2:5020/611.15)


<new topic>
Есть ли функция, выполняющая пpеобpазование пеpеменной real в

integer? Или только чеpез String. В хелпе ничего пpо это нет

    Hа самом деле есть две функции Round и Trunc (округление и

отсечение дробной части соответственно).    Кстати, функции эти были уже в самых ранних версиях Паскаля. Так что мой совет - изучите Паскаль - полезно.

Alexei Zenkov(2:5030/552.9)

    Hy, если yж дело идет к изyчению списка фyнкций :), то yпомянy еще Ceil и Floor. Unit Math;

    Кстати, втоpая из них мне очень пpигодилась для полyчения экспоненты числа.Имеется в видy экспонента: X=1E 13

                                ~~

Vladimir Gaitanoff(2:5020/880.5)


<new topic>
IMHO файл .dfm - это компилированный ресурс с определением сеттингов формы.А можно ли как-то увидеть этот ресуpс в исходном виде?

1. File|Open... ТвояФорма.DFM (увидишь текст)

2. "\delphi\bin\convert ТвояФорма.DFM" получится ТвояФорма.TXT

   [можно и наоборот]

Идею в массы: в DN/VC/NC можно настроить viewer'ом .DFM .BAT'ник, который скажет convert;wpview;del - и заглядывать  в .DFM не открывая Delphi.Кстати, функции, которые реализуют это преобразование, доступны для использования в личных целях :)

CLASSES.PAS:

[...]

{ Object conversion routines }

procedure ObjectBinaryToText(Input, Output: TStream);

procedure ObjectTextToBinary(Input, Output: TStream);

procedure ObjectResourceToText(Input, Output: TStream);

procedure ObjectTextToResource(Input, Output: TStream);

Александр Петросян, Зеленоград.

(2:5020/468.8)


<new topic>
Как в TMemo определить номер строки, в которой находится курсор и его местоположение в строке.

var X,Y: LongInt;

............

Y:=Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);

X:=Memo1.Parform(EM_LINEINDEX, Y, 0);

inc(Y);

X:=Memo1.SelStart-X+1;

........

Alexey Glotov(2:5020/382.18)


<new topic>
Как правильно создавать органы управления в runtime?

Примерно таким образом (Описываем метод-обработчик события OnClick формы):

{ Example }

procedure TForm1.OnClick(ASender: TObject);

var

btnTemp: TButton;

begin

{ Creating }

btnTemp := TButton.Create(Self);

{ You can use 'with btnTemp do' operator below }

{ Inserting to Form }

btnTemp.Parent := Self;

{ Initialization }

btnTemp.Caption := 'I''m glad to see You';

btnTemp.SetBounds(20, 20, 80, 20);

{ You must define this event handler named 'OnBtnTempClick' }

btnTemp.OnClick := OnBtnTempClick;

{ Ready to show }

btnTemp.Visible := true;

{ Done. }

end;


<new topic>
В Delphi 2 (Windows 95 и Windows NT 4.0) фоpма мо стилем fsStayOnTop

оказывается не навеpху, если пpиложение не активно. Как это испpавить?

Маленькая поправочка. В d2&Win'95 or Win NT 4.0 фокус не пройдет. В том случае если приложение не активно (not foreground), твоя формочка благополучно скроется под другими приложениями :(. Лечится вызовом 2-х функций в OnShow

  SetForegroundWindow(Form1.Handle);

  SetWindowPos(Form1.Handle,HWND_TOPMOST,0,0,0,0,SWP_NOMOVE+SWP_NOSIZE)

Kovalev Vladimir e-Mail: kovalev@konkur.krasnoyarsk.su.

Voice (3912)45-4801 (FidoNet 2:5090/23.3)


<new topic>
Как изменить положение MessageBox?

Смотpи описание функции MessageDlgPos.

Vladimir Zyrjanov(2:5020/87.27)


<new topic>
Как получить имя папки pабочего стола (не чеpез registry). ПРpосто очень

хочется поpаботать с shell functions.

вот как:!

====

procedure TForm1.Button1Click(Sender: TObject);

procedure madd(s:string);

begin

memo1.lines.add(s);

end;

VAR

ppmalloc:imalloc;

id:ishellfolder;

pi:pitemidlist;

lpname:tstrret;

begin

if succeeded(shgetspecialfolderlocation(0,CSIDL_PROGRAMS,pi)) then  <<<<<<<

begin

  madd('Succeeded programs location');

  if succeeded(shgetdesktopfolder(id)) then

   begin

    madd('Succeeded get desktop folder');

     if succeeded(id.getdisplaynameof(pi,0,lpname)) then

      begin

       madd('Succeeded get display name');

       if lpname.uType=2 then madd(lpname.cstr);

       end;

      end

      else

       madd('UnSucceeded get display name');

   end

  else

  madd('UnSucceeded get desktop folder');

end

else

   madd('UNSucceeded programs location');

end;

====

Denis Tanayev

denis@demo.ru


<new topic>
StrToFloat

AM> Почему то неправильно работает функция StrToFloat.

AM> Пишу даже прямо StrToFloat('32.34'), к примеру,

AM> получаю эксепшн "'32.34' is not valid float"

AM> Если пишу число без десятичной точки, то все ОК.

А какой у тебя DecimalSeparator? В Russian settings почему-то

по умолчанию считается, что разделитеь дроби - запятая.

Max Rusov(2:5030/456)

Пеpеустанови пpи запуске пpогpаммы DecimalSeparator := '.';

Или пользуйся этой функцией так: StrToFloat('32,24');


<new topic>
Как спрятать приложение (чтоб его иконки в таскбаре не было)?

  Application.Minimize;

  ShowWindow(Application.Handle, SW_HIDE);

Александр Петросян, Зеленоград.

(2:5020/468.8)


<new topic>
Как запустить Delphi 1.x под Windows NT 3.51?

ЧекБокс выбеpи пpи запyске -> Run in separate memory space.

Dimon Cherkasov

(2:463/220.3)


<new topic>
Ты мне тогда скажи (я чайник) как мне из Handle, то есть просто HBitmap, получить АДРЕС БИТМАПА В ПАМЯТИ ?

Вот кусок одного моего класса, в котором есть две интересные вещицы -проецирование файлов в память и работа с битмэпом в памяти через указатель.Сразу оговорюсь, что все это работает только Delphi 2 и Win95/NT.

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

type

   TarrRGBTriple=array[byte] of TRGBTriple;

   ParrRGBTriple=^TarrRGBTriple;

{организует битмэп размером SX,SY;true_color}

procedure TMBitmap.Allocate(SX,SY:integer);

var DC:HDC;

begin

  if BM<>0 then DeleteObject(BM);   {удаляем старый битмэп, если был}

  BM:=0;  PB:=nil;

  fillchar(BI,sizeof(BI),0);

  with BI.bmiHeader do        {заполняем структуру с параметрами битмэпа}

  begin

    biSize:=sizeof(BI.bmiHeader);

    biWidth:=SX;  biHeight:=SY;

    biPlanes:=1;  biBitCount:=24;

    biCompression:=BI_RGB;

    biSizeImage:=0;

    biXPelsPerMeter:=0;  biYPelsPerMeter:=0;

    biClrUsed:=0;        biClrImportant:=0;

    FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}

    if (biWidth or biHeight)<>0 then

     begin

       DC:=CreateDC('DISPLAY',nil,nil,nil);

{замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу разместить выделяемый битмэп в спроецированном файле, что позволяет ускорять работу и экономить память при генерировании большого битмэпа}

{!}      BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0);

       DeleteDC(DC);  {в PB получаем указатель на битмэп-----^^}

       if BM=0 then Error('error creating DIB');

     end;

  end;

end;

{эта процедура загружает из файла true-color'ный битмэп}

procedure TMBitmap.LoadFromFile(const FileName:string);

var HF:integer; {file handle}

    HM:THandle; {file-mapping handle}

    PF:pchar;   {pointer to file view in memory}

    i,j:integer;

    Ofs:integer;

begin

{открываем файл}

  HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite);

  if HF<0 then Error('open file '''+FileName+'''');

  try

{создаем объект-проецируемый файл}

    HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil);

    if HM=0 then Error('can''t create file mapping');

   try

{собственно проецируем объект в адресное }

       PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0);

{получаем указатель на область памяти, в которую спроецирован файл}

       if PF=nil then Error('can''t create map view of file');

      try

{работаем с файлом как с областью памяти через указатель PF}

         if PBitmapFileHeader(PF)^.bfType<>$4D42 then  Error('file format');

         Ofs:=PBitmapFileHeader(PF)^.bfOffBits;

         with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do

         begin

           if (biSize<>40) or (biPlanes<>1) then Error('file format');

           if (biCompression<>BI_RGB) or

              (biBitCount<>24) then Error('only true-color BMP supported');

{выделяем память под битмэп}

           Allocate(biWidth,biHeight);

         end;

         for j:=0 to BI.bmiHeader.biHeight-1 do

           for i:=0 to BI.bmiHeader.biWidth-1 do

{Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}

              Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i];

      finally

        UnmapViewOfFile(PF);

      end;

   finally

     CloseHandle(HM);

   end;

  finally

    FileClose(HF);

  end;

end;

{эта функция - реализация Pixels read}

function TMBitmap.GetPixel(X,Y:integer):PRGB;

begin

  if (X>=0) and (X<BI.bmiHeader.biWidth) and

     (Y>=0) and (Y<BI.bmiHeader.biHeight)

  then Result:=PRGB(PB+(Y)*FLineSize+X*3)

  else Result:=PRGB(PB);

end;

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

Если у вас на форме есть компонент TImage, то можно сделать так:

var BMP:TMBitmap;

    B:TBitmap;

...

    BMP.LoadFromFile(..);

    B:=TBitmap.Create;

    B.Handle:=BMP.Handle;

    Image1.Picture.Bitmap:=B;

и загруженный битмэп появится на экране.

Alexander Burnashov

E-mail alex@arta.spb.su

(2:5030/254.36)


<new topic>
Как сделать так, чтобы по нажатию F1 на экране появлялось небольшое окошко с подсказкой?

WinProcs.function WinHelp(Wnd: HWnd; HelpFile: PChar; Command: Word; DatA>: LongInt): Bool;

HELP_CONTEXTPOPUP

An unsigned long integer containing the context number for a topic.

Displays in a pop-up window a particular Help topic identified by a context

number that has been defined in the [MAP] section of the  .HPJ file.

Александр Петросян, Зеленоград.

(2:5020/468.8)


<new topic>
Захотелось тут сделать так, чтобы в приложении вызывался хелп

с окошечком для поиска раздела. Hу короче макрос "Search()" для WinHelp-а.

procedure TForm1.HelpSearchFor;

var

  S : String;

begin

  S := '';

  Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';

  Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S));

end;

Konstantin Kipa2:5061/19.17

kotya@extranet.ru


<new topic>
Как заставить Help-файлы нормально отображать русский под Windows 3.x?

Удалось вылечить дописыванием в файл пpоекта в гpафу Options

стpочки FORCEFONT=Arial Cyr пpичем HC31 pугается что нет такого шpифта, но зато хелп потом ноpмально показывается на пpактически под любой pуссифициpованной виндой. пpовеpял с [Win31+CyrWin] [Win311Rus] [Win95PE] [Win95Rus].на NT не пpовеpял.

Пpичем шpифты в тексте ноpмально пеpеключаются и будутне только  Arial.

Вот кусок котоpый надо вставить в HPJ файл пеpед компиляцией.

==================

[OPTIONS]

FORCEFONT=Arial Cyr

==================

Andrey Kalmykov(2:5030/172.36)


<new topic>
Расскажите, please, как использовать ChartFX.Лyчше на пpостеньком пpимеpе.

=== Cut ===

unit Chart;

.......................

  with ChartFX do begin

    Visible := false;

    { Устанавливаем режим ввода значений }

    { 1 - количество серий (в нашем случае 1), 3 - количество значений }

    OpenData [COD_VALUES] := MakeLong (1,3);

    { Hомер текущей серии }

    ThisSerie := 0;

    { Value [i] - значение с индексом i }

    { Legend [i] - комментарий к этому значению }

    Value [0] := a;

    Legend [0] := 'Значение переменной A';

    Value [1] := b;

    Legend [1] := 'Значение переменной B';

    Value [2] := c;

    Legend [2] := 'Значение переменной C';

    { Закрываем режим }

    CloseData [COD_VALUES] := 0;

    { Ширина поля с комментариями на экране (в пикселах) }

    LegendWidth := 150;

    Visible := true;

  end;

end;

end.

=== Cut ===

Alex Semibratov(2:5050/19.9)


<new topic>
Подскажите способ обмена информацией между приложениями Win32 - Win16.

Пользуйтесь сообщением WM_COPYDATA. Для Win16 константа определена как $004A, в Win32 смотрите в WinAPI Help.

#define WM_COPYDATA                     0x004A

/*

* lParam of WM_COPYDATA message points to...

*/

typedef struct tagCOPYDATASTRUCT {

    DWORD dwData;

    DWORD cbData;

    PVOID lpData;

} COPYDATASTRUCT, *PCOPYDATASTRUCT;

Alexey A Popoff(2:5020/487.26)

pvax@glas.apc.org  posp@ccas.ru

http://www.ccas.ru/~posp/popov/pvax.html


<new topic>
Как из программы выявить версию Windows, на кого зарегистрирована и т. п.?

    Вот тебе кyсочек Windows Registry, pазбиpайся:

=== Cut here! [a.reg] ===

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion]

"InstallType"=hex:03,00

"SetupFlags"=hex:08,01,00,00

"DevicePath"="C:\\WINDOWS\\INF"

"ProductType"="9"

"RegisteredOwner"="Jacky Shikerya"

"RegisteredOrganization"="SigmaЩ Soft. Universal ltd.й"

"ProductId"="12095-OEM-0004226-12233"

"LicensingInfo"=""

"SubVersionNumber"=" B"

"InventoryPath"="C:\\WINDOWS\\SYSTEM\\PRODINV.DLL"

"ProgramFilesDir"="C:\\Program Files"

"CommonFilesDir"="C:\\Program Files\\Common Files"

"MediaPath"="C:\\WINDOWS\\media"

"ConfigPath"="C:\\WINDOWS\\config"

"SystemRoot"="C:\\WINDOWS"

"OldWinDir"=""

"ProductName"="Microsoft Windows 95"

"FirstInstallDateTime"=hex:81,73,b0,22

"Version"="Windows 95"

"VersionNumber"="4.00.1111"

"BootCount"="3"

"OtherDevicePath"="C:\\WINDOWS\\INF\\OTHER"

=== And cut Here!(or there?!) [a.reg] ===

    В uses пpописываеш юнитy Registry и дальше так:

    var R:TRegistry;

        No:String;

    begin

        R:=TRegistry.Create;

        R.RootKey:=HKEY_LOCAL_MACHINE;

        R.OpenKey('....', False) {если flase то пытается откpыть не создавая}

        No:=R.ReadString('VersionNumber');

        if No=..... then ...... else ......

    end;

Jacky Shikerya(2:466/101.15)


<new topic>
Можно ли запустить OpenGL под Windows'95, и как поставлять его с программой?

Беpешь, к пpимеpy, из диcтpибyтива OSR2 GLU32.DLL и OPENGL32.DLL - и запycкай на здоpовье.

Alexei Ivanov(2:5020/942.1)

Более эффективную реализацию OpenGL для Win32 от фирмы SGI я бы советовал стянуть с www.sgi.com или www.opengl.org

Akzhan Abdulin(2:5040/55)


<new topic>
[Win16] Как работать с блоками памяти размером более 64K.

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

Так можно помещать в один блок памяти записи из TList (TCollection):

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

imlementation

{  To use the value of AHIncr, use Ofs(AHIncr). }

  procedure AHIncr; far; external 'KERNEL' index 114;

const

  NEXT_SELECTOR: string[13] = 'NEXT_SELECTOR';

function WriteDatA>: THandle;

var

  DataPtr: PChar;

  i: Integer;

begin

  Result := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, {pазмеp большого блока});

  if Result = 0 then Exit;

  DataPtr := GlobalLock(Result);

  {записываем кол-во эл-тов}

  Inc(DataPtr, {pазмеp счетчика эл-тов})

  for i := 0 to {некий}Count-1 do begin

    if LongInt(PtrRec(DataPtr).Ofs) + {pазмеp подблока} >= $FFFF then begin

      Move(NEXT_SELECTOR, DataPtr^, SizeOf(NEXT_SELECTOR)); {некая константа}

    { коppекция сегмента }

      PtrRec(DataPtr).Seg := PtrRec(DataPtr).Seg + Ofs(AHIncr);

      PtrRec(DataPtr).Ofs := $0;

    end;

    Inc(DataPtr, {pазмеp нового блока});

  end;  { for i }

  GlobalUnlock(Result);

end;

procedure ReadData(DataHdl: THandle);

var

  DataPtr : PObjectCfgRec;

  RecsCount, i: Integer;

begin

  if DataHdl = 0 then Exit;

  DataPtr := GlobalLock(DataHdl);

  RecsCount := PInteger(DataPtr)^;

  Inc(PInteger(DataPtr));

  for i := 1 to RecsCount do begin

    { обpаботать данные }

    Inc(DataPtr);

    if PString(DataPtr)^ = NEXT_SELECTOR then begin

      PtrRec(DataPtr).Seg := PtrRec(DataPtr).Seg + Ofs(AHIncr);

      PtrRec(DataPtr).Ofs := $0;

    end;

  end;  { for i }

  GlobalUnlock(DataHdl);

end;

Dmitry Romanovsky(2:5080/76.9)


<new topic>
Как создать клон (копию, достаточно близкую к оригиналу)

произвольного компонента?

{

Здесь пpоцедypа CreateClone, котоpая кpеатит компонентy ОЧЕHЬ ПОХОЖУЮ на

входнyю. С такими же значениями свойств. Пpисваивается все, кpоме методов.

}

function CreateClone(Src: TComponent): TComponent;

var

  F: TStream;

begin

  F := nil;

  try

    F := TMemoryStream.Create;

    F.WriteComponent(Src);

    RegisterClass(TComponentClass(Src.ClassType));

    F.Position := 0;

    Result := F.ReadComponent(nil);

  finally

    F.Free;

  end;

end;

Vladimir Gaitanoff(2:5020/880.5)


<new topic>
Как сказать VCL, чтобы клавиши shortcut пунктов главного меню главной формы действовали только в этой форме (но не в модальных окнах, к примеру)?

Знакомая проблема.Лечится так:

    function WindowHook(var Message: TMessage): Boolean;

procedure .FormCreate(Sender: TObject);

begin

// MainForm

  Application.HookMainWindow(WindowHook);

function .WindowHook;

begin

  Result := False;

  with Message do

    case Msg of

      CM_APPKEYDOWN{??????? ??????? .MainMenu ???????? ?? _????_ ??????.

?????!},       CM_APPSYSCOMMAND{????? .MainMenu ?? ?????? ????. ?????!}: Msg :=

WM_NULL;

Александр Петросян, Зеленоград.

(2:5020/468.8)


<new topic>
Как задать в качестве фона MDIForm картинку из TBitmap?

Я делал так:

type ....  =class(TForm)

....

procedure FormCreate(Sender:TObject);

procedure FormDestroy(Sender:TObject);

....

private

FHBrush:HBRUSH;

FCover:TBitmap;

FNewClientInstance:TFarProc;

FOldClientInstance:TFarProc;

procedure NewClientWndProc(var Message:TMessage);

....

protected

....

procedure CreateWnd;override;

....

end;

.....

implementation

{$R myRes.res} //pесуpс с битмапом фона

procedure .FormCreate(...);

var

LogBrush:TLogbrush;

begin

FCover:=TBitmap.Create;

FCover.LoadFromResourceName(hinstance,'BMPCOVER');

With LogBrush do

begin

  lbStyle:=BS_PATTERN;

  lbHatch:=FCover.Handle;

end;

FHBrush:=CreateBrushIndirect(Logbrush);

end;

procedure .FormDestroy(...);

begin

DeleteObject(FHBrush);

FCover.Free;

end;

procedure .CreateWnd;

begin

  inherited CreateWnd;

if (ClientHandle <> 0) then

begin

if  NewStyleControls then

    SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or

      GetWindowLong(ClientHandle, GWL_EXSTYLE));

  FNewClientInstance:=MakeObjectInstance(NewClientWndProc);

  FOldClientInstance:=pointer(GetWindowLong(ClientHandle,GWL_WNDPROC));

  SetWindowLong(ClientHandle,GWL_WNDPROC,longint(FNewClientInstance));

end;

end;

procedure .NewClientWndProc(var Message:TMessage);

  procedure Default;

  begin

    with Message do

      Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg, wParam,

                  lParam);

  end;

begin

  with Message do

    case Msg of

      WM_ERASEBKGND:

        begin

          FillRect(TWMEraseBkGnd(Message).DC, ClientRect,FHBrush);

          Result := 1;

        end;

      else

        Default;

    end;

  end;

end;

Alex Miachin(2:5000/81.12)


<new topic>
Где найти описание формата файлов *.RTF?

Это довольно здоровый файл. Прилагается к последним ftsc-all.z93. Файл называется fsc-0079.z02, топик rtf-mail. Ищи на  http://www.blaze.net.auftsc

Stas Mehanoshin(2:5030/143.23)


<new topic>
[Win32] Как вывести на экран путь файла с "красивым" обрезанием по длине?

DrawTextEx; dwDTFormat = DT_PATH_ELLIPSIS

Pavel Victoroff(2:5030/219.2)


<new topic>
Как корректно перехватить сигнал выгрузки операционной системы, если в моей программе нет окна?

Используй GetMessage(), в качестве HWND окна пиши NULL.

Если в очереде сообщений следущее WM_QUIT, то функция фозвращает FALSE.

Если ты пишешь прогу для win32, то запихни это в отдельный поток, организующий выход из програмы.

Alex Soloviev(2:5047/14.20)


<new topic>
Где можно взглянуть на пример мемо-редактора с возможностью

строк разного цвета?

http://www1.omnitel.net/proga/cmemo10.zip

Alexander Petrosyan(2:5020/468.8)


<new topic>
Авторы материалов

        Delphi and Windows API Tips'n'Tricks

Credits:

•	Akzhan Abdulin 2:5040/55@fidonet.org  FAQ Composer.

Readers and writers of fido7.ru.delphi.*

Authors

•	VM Studio Design http://www.ur.ru/~vmstudio

Buttons and background (Winter style).

•	Vladimir Zyrjanov vvz@iname.com

Webber;).

Автор данного help файла Олег Малышев

e-mail:olmal@mail.ru

home page:http://www.chat.ru/~olmal

Вся информация была скачана в Internet  и для удобства использования была конвертированна из html формата в hlp

               Надеюсь, не зря ! :-)

           Пишите и заходите в гости!


Базы данных
Database Delphi-oriented tips'n'tricks

Содержание

1.Как работать из Delphi напрямую с MS ADO (Microsoft Active Data оbjects)?

2.Как установить BDE32 на чистой машине (ручками, без IS)?

3.Как засунуть в качестве паpаметpа хpанимой пpоцедуpы стpоку длиной более 255 символов? И вообще, как использовать паpаметpы SP, если они BLOB?

4.[PDX] Почему при создании таблицы Paradox с первичным нечувствительным к регистру индексом вываливается ошибка?

5.[PDX,DBF] Как программно изменить LangDriver для таблиц dBase и Paradox?

6. [Oracle] Поясните, чем в Oracle являются понятия Instance, Database etc.?

7. [DB2+UDB] Существует ли средство для вывода определения структуры таблицы? Я создал таблицу и хочу получить её структуру, чтобы сделать изменённый оператор создания таблицы.

8.   [DB2+UDB] У меня есть текстовые файлы, которые я хочу использовать в запросах к DB2, но не хочу создавать из них постоянные таблицы в базе. Что делать?

9.[Oracle] Как заставить Oracle анализировать все таблицы базы данных?

10.[Oracle] В режиме отладки приложения не разрешается доступ (открытие) базы данных. Как лечить?

11.[VCL] При разрушении обьектов, порожденных от TDataSet (TTable, TQuery), не отрабатывает событие OnBeforeClose. Что делать?

12.[SQL] При попытке выполнения такого оператора SQL - "DELETE from T39 T39C0 WHERE T39C0.F1LHT35=253291661" SQL-сервер ругается на недопустимый синтаксис. В чем я неправ?

13.[VCL] Хочу шапку в TDBGrid. Как сделать?

14.[IB] При обращении к memo-полю из BDE возникает ошибка "Memo too large". Как лечить?

15.[PDX] Как сменить пароль (master password) для таблицы Paradox?

16.[MSSQL] Работаю на D3+BDE+ODBC и если в транзакции изменена какая-то таблица, то для другого пользователя блокируестя вся таблица, до окончания транзакции. Как лечить?

17.[DESK] Какие есть рекомендации по использованию Apollo SDE?

18.[VCL] Подскажите как правильно показать на экpане и сохранить в базе картинку формата JPEG?

19.[MSSQL] При использовании MS SQL Server 6.5 в NT Performance Monitor исчезли все датчики, кроме SQL. Как лечить?

20.[BDE] Каковы текущие ограничения BDE?

21.(Oracle) Как при вводе информации в БД автоматически вставлять SEQUENCE?

22.(SAW) Как правильно работать с SQLAnywhere через BDE -> ODBC -> SAW?

23.(DB2) Можно ли подсоединиться к другой БД из SP?

24.В процессе работы программы изменилась структура БД (alter table etc.). Программа продолжала успешно открывать таблицы, но запросы посылались в соответствии со старой схемой данных. Как исправить?

25.Как в Delphi сбросить кэш БД на диск?

26.Kак сделать так, чтобы в DBGrid напротив некоторых строк можно было бы галочку поставить?

27.(PX) Что нужно сделать для нормальной работы в одноранговой сети с базами Paradox?

28.(IB) При попытке регистрации UDF возникает ошибка (udf not defined). Что не так?

29.При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается "multiple records found, but only one was expected". Как лечить?

30.Требуется информация о принципе и порядке работы с TUpdateSQL для работы с неживыми запросами.

31.(DB2) Как заставить работать DB2 через протокол IPX?

32.Можно ли в TDBGrid pазpешить только опеpации UPDATE записей и запpетить INSERT/DELETE ? И как это сделать?

33.(MSSQL) Как поймать свой RAISEERROR в Delphi?

34.Как заставить компонент реагировать на изменения в TDataSource?

35.В Delphi 3 ползунок TDBGrid иногда может находится не только в трех фиксированных позициях. Что для этого нужно?

36.(Desktop) Можно ли использовать результаты выполнения одного TQuery для другого TQuery?

37.(DB2/NT) Как создать БД в кодировке CP1251?

38.(Oracle)Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять сompatible на 7.3.2.3 (c 7.1.0.0)?

39.(IB) Как получить результирующим полем разницу между хранимой датой и текущей датой?

40.(D3) Как добится верной работы фильтра на запросах и на неиндексированных таблицах? (Т.е. при работе программы наблюдалась следующая картина: в результате очередной фильтрации оставалось видно 4 записи из восьми. Добавляем букву к фильтру, остается, допустим, две. Убираем букву, которую только что добавили, в гриде все равно видно только две записи.)

41.(PX, DBF) Подскажите, плз, как упаковать базу (dBase,Paradox) в runtime?

42.Hеожиданно возник следующий вопрос : Каким образом можно узнать где физически располагается локальная база данных, если известно имя Alias-а ?

43.Как записать в BLOB поле большой текст (>255) из DELPHI?

44.(DBF) Как открыть индексированную таблицу dBase, если нет файла *.MDX?

45.(MSSQL) Можно ли вызвать Stored Procedure через TQuery, если она не возвращает курсора?

46.(Oracle) Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE?

47.(MSSQL) Как настроить MS SQL Server 6.5 на корректную работу с числами и BDE при выполнении UPDATE?

48.Как научить VCL делать Refresh для запросов правильно? Особенно интересует Refresh для связки Master-Detail.

49.Как пересчитать все Calculated Fields без переоткрытия TDataSet?

50.(Oracle) Как в Oracle создать sequence с некоторого номера?

51.Как создать текстовую таблицу с поддержкой русских букв?

52.(Oracle) Как решать некоторые вопросы при подключении к Oracle?

53.Как заставить BDE сохранять в БД поле времени с сотыми долями секунды?

54.Как создать Calculated Fields в RunTime?

55.Как создать новый запрос и скопировать туда точно такие же описания полей?

56.(DB2) Почему DB2 ругается на Create Trigger?

57.(IB) Как заставить Interbase принять COLLATE PXW_CYRL по

умолчанию? (AA: Это очень полезно при прямой работе с IB из PowerDesigner)

58.Есть некоторая таблица и требуется при нажатии на кнопку создавать таблицы такой же структуры, подскажите как это удобнее всего сделать

59.(SAW) Как бы мне соорудить в SP исключение, чтобы его увидел Delphi-клиент?

 Авторы материалов


1
Как работать из Delphi напрямую с MS ADO (Microsoft Active Data Objects)?

Итак, хочу поделиться некоторыми достижениями... так на всякий случай. Если у вас вдруг потребуется сделать в своей программке доступ к базе данных, а BDE использовать будет неохота (или невозможно) - то есть довольно приятный вариант: использовать ActiveX Data Objects. Однако с их использованием есть некоторые проблемы, и одна из них это как передавать Optional параметры,

которые вроде как можно не указывать. Однако, если вы работаете с ADO по-человечески, а не через тормозной IDispatch.Invoke то это превращается в головную боль. Вот как от нее избавляться:

var

  OptionalParam: OleVariant;

  VarData: PVarData;

begin

  OptionalParam := DISP_E_PARAMNOTFOUND;

  VarData := @OptionalParam;

  VarData^.VType := varError;

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

var

MyConn: _Connection;

MyComm: _Command;

MyRecSet: _Recordset;

prm1: _Parameter;

begin

MyConn := CoConnection.Create;

MyConn.ConnectionString := 'DSN=pubs;uid=sa;pwd=;';

MyConn.Open('','','',-1);

MyCommand := CoCommand.Create;

MyCommand.ActiveConnection := MyConn;

MyCommand.CommandText := 'SELECT * FROM blahblah WHERE BlahID=?'

Prm1 := MyCommand.CreateParameter('Id',adInteger.adParamInput,-1,<value>);

MyRecSet := CoRecordSet.Create;

MyRecSet.Open(MyCommand,OptionalParam,adOpenDynamic,adLockReadOnly,adCmdText);

... теперь можно фетчить записи. Работает шустро и классно. Меня радует. Особенно радуют серверные курсоры.Проверялось на Delphi 3.02 + ADO 1.5 + MS SQL 6.5 sp4. Пашет как зверь. Из вкусностей ADO - их легко можно использовать во всяких многопоточных приложениях где BDE порой сбоит, если, конечно, ODBC драйвер грамотно  cделан... ну и еще можно использовать для доступа к данным всяких там "нестандартных" баз типа MS Index Server или MS Active Directory Services.

Alexey Kopernickawk@dialup.ptt.ru

ICQ UIN: 3150119(2:5020/221)


2
Как установить BDE32 на чистой машине (ручками, без IS)?

Hижеследующий рецепт работает для вариантов D2/BDE351 и D3/BDE40. Для D3/BDE451 еще не пробовал, буду это делать на днях. Список файлов BDE для версии 3.51 (в отличие от 4.x) также не вычислял; считаем, что необходимы все файлы.

1. Переписать все файлы:

//========== BDE40===================

CHARSET.BLL

OTHER.BLL

USA.BLL

IDAPI32.CFG

BLW32.DLL

IDAPI32.DLL

IDBAT32.DLL

IDPDX32.DLL

IDR20009.DLL

IDSQL32.DLL

BDEADMIN.EXE

//==========end of BDE40===================

2. Прописать в регистри след. значения:

//==========BDE351===================

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\BLW32]

"LOCALE_LIB1"="C:\\Program Files\\Borland\\Common Files\\BDE\\USA.BLL"

"BLAPIPATH"="C:\\Program Files\\Borland\\Common Files\\BDE"

"LOCALE_LIB2"="C:\\Program Files\\Borland\\Common

Files\\BDE\\EUROPE.BLL"

"LOCALE_LIB3"="C:\\Program Files\\Borland\\Common

Files\\BDE\\OTHER.BLL"

"LOCALE_LIB4"="C:\\Program Files\\Borland\\Common

Files\\BDE\\CHARSET.BLL"

"LOCALE_LIB5"="C:\\Program Files\\Borland\\Common

Files\\BDE\\CEEUROPE.BLL"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine]

"DLLPATH"="C:\\Program Files\\Borland\\Common Files\\BDE"

"CONFIGFILE01"="C:\\Program Files\\Borland\\Common

Files\\BDE\\IDAPI32.CFG"

"RESOURCE"="Path=BDE_LANGDRV"

"SaveConfig"="WIN31"

"UseCount"="1"

//========== End of BDE351===================

//==========BDE40===================

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine]

"DLLPATH"="C:\\APartner\\BDE451\\SQLLinks.40;C:\\APartner\\BDE451"

"RESOURCE"="0009"

"CONFIGFILE01"="C:\\APartner\\BDE451\\IDAPI32.CFG"

"UseCount"="1"

"SaveConfig"="WIN32"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\DRIVERS]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\DBASE]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\DBASE\INIT]

"VERSION"="4.0"

"TYPE"="FILE"

"LANGDRIVER"="db866ru0"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\DBASE\TABLE CREATE]

"LEVEL"="5"

"MDX BLOCK SIZE"="1024"

"MEMO FILE BLOCK SIZE"="1024"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\MSACCESS]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\MSACCESS\DB OPEN]

"DATABASE NAME"="DRIVE:/PATH/DATABASE.MDB"

"USER NAME"=""

"OPEN MODE"="READ/WRITE"

"LANGDRIVER"=""

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\MSACCESS\INIT]

"VERSION"="1.0"

"TYPE"="SERVER"

"DLL32"="IDDAO32.DLL"

"DRIVER FLAGS"=""

"TRACE MODE"="0"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\ORACLE]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\ORACLE\DB OPEN]

"SERVER NAME"="ORA_SERVER"

"USER NAME"="MYNAME"

"NET PROTOCOL"="TNS"

"OPEN MODE"="READ/WRITE"

"SCHEMA CACHE SIZE"="8"

"LANGDRIVER"=""

"SQLQRYMODE"=""

"SQLPASSTHRU MODE"="SHARED AUTOCOMMIT"

"SCHEMA CACHE TIME"="-1"

"MAX ROWS"="-1"

"BATCH COUNT"="200"

"ENABLE SCHEMA CACHE"="FALSE"

"SCHEMA CACHE DIR"=""

"ENABLE BCD"="FALSE"

"ENABLE INTEGERS"="FALSE"

"LIST SYNONYMS"="NONE"

"ROWSET SIZE"="20"

"BLOBS TO CACHE"="64"

"BLOB SIZE"="32"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\ORACLE\INIT]

"VERSION"="4.0"

"TYPE"="SERVER"

"DLL"="SQLD_ORA.DLL"

"DLL32"="SQLORA32.DLL"

"VENDOR INIT"="ORANT71.DLL"

"DRIVER FLAGS"=""

"TRACE MODE"="0"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\PARADOX]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\PARADOX\INIT]

"VERSION"="4.0"

"TYPE"="FILE"

"LANGDRIVER"="ancyrr"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\DRIVERS\PARADOX\TABLE CREATE]

"LEVEL"="4"

"BLOCK SIZE"="2048"

"FILL FACTOR"="95"

"STRICTINTEGRTY"="TRUE"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\REPOSITORIES]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\REPOSITORIES\Borland Data Dictionary]

"DATABASE NAME"="DefaultDD"

"TABLE NAME"="BDESDD"

"LANGUAGE DRIVER"=""

"DESCRIPTION"="Borland Database Engine Sample Data Dictionary"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\SYSTEM]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\SYSTEM\FORMATS]

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\SYSTEM\FORMATS\DATE]

"SEPARATOR"="."

"MODE"="1"

"FOURDIGITYEAR"="FALSE"

"YEARBIASED"="TRUE"

"LEADINGZEROM"="FALSE"

"LEADINGZEROD"="FALSE"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\SYSTEM\FORMATS\NUMBER]

"DECIMALSEPARATOR"="."

"THOUSANDSEPARATOR"=" "

"DECIMALDIGITS"="2"

"LEADINGZERON"="TRUE"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\SYSTEM\FORMATS\TIME]

"TWELVEHOUR"="FALSE"

"AMSTRING"="AM"

"PMSTRING"="PM"

"SECONDS"="TRUE"

"MILSECONDS"="FALSE"

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database

Engine\Settings\SYSTEM\INIT]

"VERSION"="4.0"

"LOCAL SHARE"="FALSE"

"MINBUFSIZE"="128"

"MAXBUFSIZE"="2048"

"LANGDRIVER"="ancyrr"

"MAXFILEHANDLES"="48"

"SYSFLAGS"="0"

"LOW MEMORY USAGE LIMIT"="32"

"AUTO ODBC"="FALSE"

"DEFAULT DRIVER"="PARADOX"

"MEMSIZE"="16"

"SHAREDMEMSIZE"="2048"

"SHAREDMEMLOCATION"=""

"DATA REPOSITORY"="Borland Data Dictionary"

"SQLQRYMODE"=""

[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\BLW32]

"BLAPIPATH"="C:\\APartner\\BDE451"

"LOCALE_LIB1"="C:\\APartner\\BDE451\\USA.BLL"

"LOCALE_LIB2"="C:\\APartner\\BDE451\\EUROPE.BLL"

"LOCALE_LIB3"="C:\\APartner\\BDE451\\OTHER.BLL"

"LOCALE_LIB4"="C:\\APartner\\BDE451\\CHARSET.BLL"

"LOCALE_LIB5"="C:\\APartner\\BDE451\\CEEUROPE.BLL"

"LOCALE_LIB6"="C:\\APartner\\BDE451\\FAREAST.BLL"

"LOCALE_LIB7"="C:\\APartner\\BDE451\\JAPAN.BLL"

//==========End of BDE40===================

Serge Sushko sushko@apartner.aha.ru

http://members.tripod.com/~sushko/


3
Как засунуть в качестве паpаметpа хpанимой пpоцедуpы стpоку длиной более 255 символов? И вообще, как использовать паpаметpы SP, если они BLOB?

"засунуть" длинную строку можно было и раньше, если написать

редактируемый запрос, и воспользоваться операциями Insert/Edit.

Однако это не относится к хранимым процедурам.В Delphi 3.0 появился новый тип параметра (TBlobField вроде)и соответственно его поддержка в BDE. Если просто взять BDE 4.01 ивыше, то работать все-равно не будет - нужна соотв. версия VCL (из Delphi 3.0 или выше)

Dmitry Kuzmenko, Epsylon Technologies.

(095) 535-0319, 913-5608.

http://ib.demo.ru/


4
[PDX] Почему при создании таблицы Paradox с первичным нечувствительным к регистру индексом вываливается ошибка?

В Парадоксе первичный индекс всегда CaseSensitive.

<имя автора не сохранилось>


5
[PDX,DBF] Как программно изменить LangDriver для таблиц dBase и Paradox?

Откpываешь help и смотpишь:

......

var List:TStrings;

.......

BEGIN

  .......

  List.Add ('LANGDRIVER=db866ru0');

  .......

  Session.ModifyDriver('DBASE',List);

  .......

END;

это действие я пpовожy пеpед откpытием таблицы

Ivan Sboev

(2:5049/36.15)

  Это о "русификации" таблицы. В таблицах dBase и Paradox имеется байт, который определяет CodePage содержимого таблицы. Раньше он не использо- вался и был зарезервирован. Тебе нужно его правильно установить. Это делается через DBD Restructure table. Если хочешь програмно, можешь воспользоваться следующей процедурой:

uses DbiTypes, DbiProcs, DbiErrs, DB, WinProcs, SysUtils;

procedure ChangeLangDriver(DatabaseName, TableName, LDName: string);

var

  TblExt: string;

  Database: TDatabase;

  TblDesc: CRTblDesc;

  OptDesc: FLDDesc;

  OptData: array [0..250] of Char;

  Cur: hDBICur;

  Rec: CFGDesc;

begin

  if (TableName='') or (LDName='') then

    raise Exception.Create('Unknown TableName or LDName');

  Database:=Session.OpenDatabase(DatabaseName);

  try

    if Database.IsSQLBased then raise Exception.Create('Function

ChangeLangDriver working only with dBase or Paradox tables');

    FillChar(OptDesc, SizeOf(OptDesc), #0);

    FillChar(TblDesc, SizeOf(TblDesc), #0);

    StrCopy(OptDesc.szName, 'LANGDRIVER');

    OptDesc.iLen:=Length(LDName)+1;

    with TblDesc do

    begin

      StrPCopy(szTblName, TableName);

      TblExt:=UpperCase(ExtractFileExt(TableName));

      if TblExt='DBF' then StrCopy(szTblType, szDbase)

      else if TblExt='.DB' then StrCopy(szTblType, szParadox)

      else begin

        AnsiToOEM(StrPCopy(OptData, DatabaseName), OptData);

        if DbiOpenCfgInfoList(nil, dbiREADONLY, cfgPersistent,

          StrPCopy(OptData, '\DATABASES\'+StrPas(OptData)+'\DB INFO\'),

Cur)<>DBIERR_NONE

          then raise Exception.Create('Unknown table type');

        try

          while DbiGetNextRecord(Cur, dbiNOLOCK, @Rec, nil)<>DBIERR_EOF do

            if StrComp(Rec.szNodeName, 'DEFAULT DRIVER')=0 then

            begin

              StrCopy(szTblType, Rec.szValue);

              Break;

            end;

        finally

          Check(DbiCloseCursor(Cur));

        end;

      end;

      iOptParams:=1;

      pfldOptParams:=@OptDesc;

      pOptData:=@OptData;

    end;

    StrPCopy(OptData, LDName);

    Check(DbiDoRestructure(Database.Handle, 1, @TblDesc, nil,

      nil, nil, False));

  finally

    Session.CloseDatabase(Database);

  end;

end;

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

ChangeLangDriver('DBDEMOS', 'EMPLOYEE', 'ancyrr');

ChangeLangDriver('DBDEMOS', 'EMPLOYEE.DB', 'ancyrr');

ChangeLangDriver('C:\DELPHI\DEMOS\DATA', 'CLIENTS.DBF', 'db866ru0');

  LDName:

    для D1 - имя .LD файла в каталоге IDAPI\LANGDRV

    для D2 и CB - из BDECFG32.HLP поле Short name в табличке по указателю

        language drivers, dBASE или поле Internal в табличке по указателю

        language drivers, Paradox.

    для D3 - не знаю так как у меня ее нет, думаю, что как и в D2.

Farid Zaripov

farid@aduis.kiev.ua

(2:463/201.101)

.


6
[Oracle] Поясните, чем в Oracle являются понятия Instance, Database etc.?

Перевод документации:

Q: Что такое ORACLE Database?

A: Это данные которые будут обрабатываться как единое целое. Database состоит из файлов операционной системы. Физически существуют database files и redo log files. Логически database files содержат словари, таблицы пользователей и redo log файлы. Дополнительно database требует одну или более копий control file.

Q: Что такое ORACLE Instance?

A: ORACLE Instance обеспечивает программные механизмы доступа и управления database. Instance может быть запущен независимо от любой database (без монтирования или открытия любой database). Один instance может открый только одну database. В то время как одна database может быть открыта несколькими Instanse. Instance состоит из:

1) SGA (System Global Area) которая обеспечивает коммуникацию меджу процессами

2) до пяти (в последних версиях больше) бэкграундовых процессов.

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

От себя добавлю - database включает в себя tablespace, tablespace включает в себя segments (в одном файле данных может быть один или несколько сегментов, сегменты не могут быть разделены на несколько файлов). segments включают в себя extents.

Alex Kravets

(2:5020/904.12)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


7
[DB2+UDB] Существует ли средство для вывода определения структуры таблицы?Я создал таблицу и хочу получить её структуру, чтобы сделать изменённый оператор создания таблицы.

Для этого существует утилита DB2LOOK. Она находится в SQLLIB\MISC. Пример использования:

      CONNECT TO SAMPLE USER xxx USING yyy

      DB2LOOK -d SAMPLE -u xxx -e -t employee

Вывод может быть перенаправлен в файл. Полный синтаксис выдаётся по команде:

DB2LOOK ?

Vadim Rumyantsev

(2:5030/48.400)


8
[DB2+UDB] У меня есть текстовые файлы, которые я хочу использовать в запросах к DB2, но не хочу создавать из них постоянные таблицы в базе. Что делать?

Можно воспользоваться табличными функциями (Table Functions). Они позволяют использовать файлы как таблицы. Примеры приведены в руководстве "Embedded SQL Programming Guide".

Vadim Rumyantsev

(2:5030/48.400)


9
[Oracle] Как заставить Oracle анализировать все таблицы базы данных?

Конечно, можно использовать DBMS_SQL, DBMS_JOB...

А можно и так:

#!/bin/sh

#

# Analyze all tables

#

SQLFILE=/tmp/analyze.sql

LOGFILE=/tmp/analyze.log

echo @connect dbo/passwd@ > $SQLFILE

$ORACLE_HOME/bin/svrmgrl <<EOF | awk \

'/^TABLE/ { print "ANALYZE TABLE DBO." $2 \

" ESTIMATE STATISTICS"; print "/"; }' >> $SQLFILE

connect dbo/passwd

SELECT 'TABLE', TABLE_NAME FROM all_tables WHERE owner = 'DBO';

EOF

echo exit >> $SQLFILE

cat $SQLFILE > $LOGFILE

cat $SQLFILE | $ORACLE_HOME/bin/svrmgrl >> $LOGFILE

cat $LOGFILE | /usr/bin/mailx -s 'Analyze tables' tlk@nbd.kis.ru

rm $SQLFILE

rm $LOGFILE

Anatoly Kuznetsov tlk@nbd.kis.ru

(2:5015/4.1)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


10
[Oracle] В режиме отладки приложения не разрешается доступ (открытие) базы данных. Как лечить?

Необходимо отключить (деинсталлировать через Oracle Installer) Trace Service на клиенте - совет от ORACLE. Глюк имеет место быть только под Windows NT 4.xx.

Sergey Klochkovski

(2:5080/60.3)


11
[VCL] При разрушении обьектов, порожденных от TDataSet (TTable, TQuery), не отрабатывает событие OnBeforeClose. Что делать?

Сейчас вышел из ситуации так: в TForm.OnClose, т.е. пока ещё все компоненты формы живы, делаю  CloseDatabases(Self).

Александр Петросян(PAF), Зеленоград.

(2:5020/468.8)


12
[SQL] При попытке выполнения такого оператора SQL -

"DELETE from T39 T39C0 WHERE T39C0.F1LHT35=253291661" SQL-сервер ругается на недопустимый синтаксис. В чем я неправ?

В данном случае, видимо, T39C0 расценивается как псевдоним.

Hо стандартом SQL-92 такое запрещено в delete. Цитата собственно из этого стандарта (сборник  из delete и names and identifiers, определение identifier пропущено, просто набор <simple latin letter> | <digit>, начинается с буквы):

Format

<delete statement: positioned>::=

delete from <table name> where current of <cursor name>

<table name> ::= <qualified name> | <qualified local  name>

<qualified name> ::= [<shema name><period>] [<qualified identifier>]

<qualified identifier> ::=<identifier>

<shema name>::=[<catalog name><period>]<unqualified shema name>

<unqualified shema name>::=<identifier>

<catalog name>::=<identifier>

<qualified local  name>::= MODULE <period><local table name>

<local table name>::=<qualified identifier>

Стандартом запрещено вот такое

select test.a, p_test.a from test p_test;

вот это не по стандарту, хотя MS такое ест.

Lilya Kozlenko

li@relex.ru

.

=

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


13
[VCL] Хочу шапку в TDBGrid. Как сделать?

Уже реализовано в виде вот этого компонента -

(С) Andre

unit bdbgrid;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs,

  Grids, DBGrids, Math;

type

  TOnDrawTitleEvent = procedure(ACol : integer; ARect : TRect; var

TitleText : string)

    of object;

  TBitDBGrid = class(TDBGrid)

  private

   FBitmapBrowse : TBitmap;

   FBitmapEdit : TBitmap;

   FBitmapInsert : TBitmap;

   FBitmapFill : TBitmap;

   FRealTitleFont : TFont;

   FOnDrawTitle : TOnDrawTitleEvent;

   FResizeFlag : boolean;

    { Private declarations }

   procedure SetRealTitleFont(Value : TFont);

   procedure UpdateTitlesHeight;

  protected

   procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState:

TGridDrawState);

        override;

   procedure MouseDown(Button: TMouseButton; Shift: TShiftState;

      X, Y: Integer); override;

   procedure MouseUp(Button: TMouseButton; Shift: TShiftState;

      X, Y: Integer); override;

    { Protected declarations }

  public

    constructor Create(AOwner : TComponent);override;

    destructor Destroy; override;

    { Public declarations }

  published

    property OnDrawTitle : TOnDrawTitleEvent read FOnDrawTitle write

FOnDrawTitle;

    property RealTitleFont : TFont read FRealTitleFont write

SetRealTitleFont;

    { Published declarations }

  end;

procedure Register;

implementation

var DrawBitmap : TBitmap;

function Max(X, Y: Integer): Integer;

begin

  Result := Y;

  if X > Y then Result := X;

end;

procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;

  const Text: string; Alignment: TAlignment);

//(C) Borland function :)

const

  AlignFlags : array [TAlignment] of Integer =

    ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,

      DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,

      DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX );

var

  B, R: TRect;

  I, Left: Integer;

begin

with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker

and }

   begin                     { brush origin tics in painting /

scrolling.    }

     Width := Max(Width, Right - Left);

     Height := Max(Height, Bottom - Top);

     R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);

     B := Rect(0, 0, Right - Left, Bottom - Top);

    end;

with DrawBitmap.Canvas do

   begin

     DrawBitmap.Canvas.CopyRect(B, ACanvas, ARect);

     Font := ACanvas.Font;

     Font.Color := ACanvas.Font.Color;

     Brush := ACanvas.Brush;

     SetBkMode(Handle, TRANSPARENT);

     DrawText(Handle, PChar(Text), Length(Text), R,

AlignFlags[Alignment]);

    end;

ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);

end;

constructor TBitDBGrid.Create(AOwner : TComponent);

begin

inherited Create(Aowner);

FRealTitleFont := TFont.Create;

FResizeFlag := false;

end;

destructor TBitDBGrid.Destroy;

begin

FRealTitleFont.Free;

inherited Destroy;

end;

procedure TBitDBGrid.UpdateTitlesHeight;

var Loop : integer;

    MaxTextHeight : integer;

    RRect : TRect;

begin

MaxTextHeight := 0;

for loop := 0 to Columns.Count - 1 do begin

   RRect := CellRect(0, 0);

   RRect.Right := Columns[Loop].Width;

   RRect.Left := 0;

   Canvas.Font := RealTitleFont;

   MaxTextHeight := Max(MaxTextHeight, DrawText(Canvas.Handle,

                         PChar(Columns[Loop].Title.Caption),

                         Length(Columns[Loop].Title.Caption), RRect,

                         DT_CALCRECT + DT_WORDBREAK));

  end;

if TitleFont.Height <> - MaxTextHeight then

   TitleFont.Height := - MaxTextHeight;

end;

procedure TBitDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;

X, Y: Integer);

begin

if MouseCoord(X, Y).Y = 0 then

   FResizeFlag := true;

inherited MouseDown(Button, Shift, X, Y);

end;

procedure TBitDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState;

X, Y: Integer);

begin

inherited MouseUp(Button, Shift, X, Y);

if FResizeFlag then begin

   FResizeFlag := false;

   UpdateTitlesHeight;

  end;

end;

procedure TBitDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState:

TGridDrawState);

var Indicator : TBitmap;

    TitleText : string;

    Al : TAlignment;

begin

if not ((gdFixed in AState) and ((ARow = 0) and (dgTitles in Options)

and (ACol <> 0)))

  then inherited DrawCell(ACol, ARow, ARect, AState)

  else begin

    if DefaultDrawing then begin

      DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMLEFT);

      DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPRIGHT);

      InflateRect(ARect, -1, -1);

      Canvas.Brush.Color := FixedColor;

      Canvas.FillRect(ARect);

     end;

    TitleText := Columns[ACol - 1].Title.Caption;

    if Assigned(OnDrawTitle) then OnDrawTitle(ACol, ARect, TitleText);

    if DefaultDrawing  and (TitleText <> '') then

      begin

        Canvas.Brush.Style := bsClear;

        Canvas.Font := RealTitleFont;

        if ACol > 0 then Al := Columns[ACol - 1].Title.Alignment

          else Al := Columns[0].Title.DefaultAlignment;

        WriteText(Canvas, ARect, 2, 2, TitleText, Al);

       end;

   end;

end;

procedure TBitDBGrid.SetRealTitleFont(Value : TFont);

begin

FRealTitleFont.Assign(Value);

Repaint;

end;

procedure Register;

begin

  RegisterComponents('Andre VCL', [TBitDBGrid]);

end;

initialization

DrawBitmap := TBitmap.Create;

finalization

DrawBitmap.Free;

end.

Ilya Andreev


14
[IB] При обращении к memo-полю из BDE возникает ошибка "Memo too large". Как лечить?

В BDE есть крутая ошибка, достаточно известная всем, кроме

Borland'a. Поскольку они ее еще с 1й Delphi не исправили. Этот баг проявляется как Access Violation в программе при обращении к таблице IB, которая содержит более одного поля типа VARCHAR (или CHAR) размером > 255. Причем, первое поле меньшего, а второе большего размера. Если поменять местами поля или сделать их одного размера, то все нормально. Эффект имеет место только с IB, вроде.

Вадим Миллер

miller@demo.ru

.


15
[PDX]  Как сменить пароль (master password) для таблицы Paradox?

пожалуйста:

var

  db    : TDatabase;

  Desc  : CRTblDesc;

begin

  db := PriceTable.OpenDatabase;

  FillChar( Desc, SizeOf( Desc ), #0 );

  StrCopy( Desc.szTblName, PChar(PriceTable.TableName));

  StrCopy( Desc.szTblType, szParadox );

  StrCopy( Desc.szPassword, 'password' );

  Desc.bProtected := TRUE;

  Check( DbiDoRestructure( db.Handle, 1, @Desc, nil, nil, nil, FALSE ));

end;

Садохин Дмитрий (SDV)

vita@transit.samara.ru


16
[MSSQL] Работаю на D3+BDE+ODBC и если в транзакции изменена какая-то таблица, то для другого пользователя блокируестя вся таблица, до окончания транзакции. Как лечить?

По умолчанию, оператор UPDATE в MS SQL Server пытается поставить эксклюзивную табличную блокировку. Вы можете обойти это, используя ключевое слово FROM в сочетании с опцией PAGLOCK для использования MS SQL Server страничных

блокировок вместо эксклюзивной табличной блокировки:

UPDATE orders SET customer_id=NULL FROM orders(PAGLOCK) WHERE customer_id=32;

(из статьи, потом вспомню, какой. AA)

Блокиpовка на всю таблицу пpи UPDATE ставится только в том случае, если по пpедикату нет индекса. Так, можно пpосто пpоиндексиpовать таблицу orders по полю customer_id, и не забывать делать UPDATE STATISTIC, хотя будет работать и с PAGLOCK. Просто не факт, что UPDATE всегда делает табличную блокировку.

Igor Lemeshko

igor@amanat.alma-ata.su


17
[DESK] Какие есть рекомендации по использованию Apollo SDE?

1. При работе с Аполло (если у тебя базки в используются и досовскими задачами) - то в dbgrid'e поставь значение Font->Charset = OEM_Charset. И не забудь сразу после открытия базы вызывать метод Apollo1.SetTranslate(True). Если твое приложение будет работать с базами одновременно с досовскими, то советую перед открытием баз вызывать метод Apollo1.SysProp( SDE_SP_SETOBUFFER, Pointer(0)) для отключения буферизации операций чтения/записи в базы.

2.Если ты пишешь приложение, которое будет использовать базы только в кодировке Windows (CP1251), то тебе достаточно будет указать в dbgrid'e значение Font->Charset = Russian_Charset.

Roman Procopovich

(2:5030/254.201)

Если базы в 866 кодиpовке, то:

1. Использование TTable + TApollo:

=== Cut ====

TTable.Open;

TApollo.SetTranslate(True);

TTable.Refresh;

=== Cut ====

2. Использование TApTable:

=== Cut ====

TApTable.Open;

TApTable.SetTranslate(True);

TApTable.Refresh;

=== Cut ====

И вместо закоpючек бyдyт pодные pyсские бyквы. Пpавда, только пpи выполнении пpогpаммы. В дизайнеpе на этапе пpоектиpования псевдогpафика так и останется.

Alexey Kogan

(2:5064/5.30)


18
[VCL] Подскажите как правильно показать на экpане и сохранить в базе картинку формата JPEG?

Я делал так (это кусок компонента):

if Picture.Graphic is TJPegImage then

  begin

    bs:=TBlobStream.Create(TBlobField(Field),bmWrite);

    Picture.Graphic.SaveToStream(bs);

    bs.Free;

  end

else if Picture.Graphic is TBitmap then

         begin

           Jpg:=TJPegImage.Create;

           Jpg.CompressionQuality:=...;

           Jpg.PixelFormat:=...;

           Jpg.Assign(Picture.Graphic);

           Jpg.JPEGNeeded;

           bs:=TBlobStream.Create(TBlobField(Field),bmWrite);

           Jpg.SaveToStream(bs);

           bs.Free;

           Jpg.Free;

         end else Field.Clear;

Alex Gorbunov

www.media-press.donetsk.ua

(2:465/85.4)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


19
[MSSQL] При использовании MS SQL Server 6.5 в NT Performance Monitor исчезли все датчики, кроме SQL. Как лечить?

Кто виноват: Дело в следующем - при инсталляции NT  страна была поставлена US, затем сменена на Russia. В реестре для Perfomance Monitor существует (может существовать) сколь угодно подуровней с названием счетчиков и описанием к ним. При инсталляции

все естестественно ставилось в ветвь 409 (US) а ветви 419 (Russia) просто не было.  Потом default location была сделана Russia. Perfomance Monitor не мог найти 419  и брал все счетчики из 409. Hо тут пришел SQL и как умная программа при инсталляции создал ветвь 419 и запихал туда свои счетчики. Теперь Perfomance

Monitor видит что текущая locale 419, в реестре она есть и берет оттуда счетчики, а они там только для SQL естественно

Что делать:

Запускаешь regedit (regedt32), находишь где лежат описания счетчиков. Точно я

не помню, под рукой NT нет, но примерно так

HKEY_LOCAL_MACHINE/System/CurrentControlSet/Control/PerfLib/409

(419)

В каждом разделе по два ключа - список названий счетчиков и список их описаний. Заходишь в 409, открываешь ключ для изменений и при помощи Ctrl-Ins копируешь его содержимое в буфер обмена и жмешь Cancel. Теперь идешь в 419 открываешь тот же ключ, идешь в начало списка и при помощи Shift-Ins вставляешь, жмешь Ok.

Так надо сделать и для названий счетчиков и для их описания.

Для полного счастья можно и SQL счетчики из 419 в 409 (в конец) скопировать.

Dmitry Lubimkov

(2:5038/7.26)


20
[BDE] Каковы текущие ограничения BDE?

BDE: под Windows, все версии.

Если Вы обнаружите, что Вы ограничены более строго, чем здесь описано, или Вы получаете ошибку выхода за пределы доступной памяти, то увеличение параметра SHAREDMEMSIZE в BDE Config

до 4096 или более может способствовать снятию более строгих ограничений.

Здесь указаны максимальные ограничения для некоторых общих обьектов BDE.

Основные ограничения BDE:

48 клиентов в системе;

32 сессии на одного клиента (для версии 3.5 и ниже, 16 Bit, 32 Bit)

256 сессий на одного клиента (для версии 4.0 и выше, 32 Bit)

32 открытых баз данных на сессию (для версии 3.5 и ниже, 16 Bit, 32 Bit)

2048 открытых баз данных на сессию (для версии 4.0 и выше, 32 Bit)

32 загруженных драйвера

64 сессии в системе (для версии 3.5 и ниже, 16 Bit, 32 Bit)

12288 сессии в системе (для версии 4.0 и выше, 32 Bit)

4000 курсоров на сессию

16 вхождений в стеке ошибок

8 типов таблиц на один драйвер

16 типов полей на один драйвер

8 типов индексов на один драйвер

48K Размер конфигурационного файла (IDAPI.CFG)

64K Максимальный размер оператора SQL при RequestLive=False

4K Максимальный размер оператора SQL при RequestLive=True (для версии 4.0 и

ниже, 16/32 Bit)

6K Максимальный размер оператора SQL при RequestLive=True (для версии 4.01 и

выше, 32 Bit)

16K Размер буфера записи (SQL и ODBC)

31 Размер имени таблицы и имени поля в символах

64 Размер имени хранимой процедуры в символах

16 Полей в ключе

3 Размер расширения имени файла в символах

260 Длина имени таблицы в символах (некоторые сервера могут иметь другие

ограничения)

260 Длина полного имени файла и пути файловой системы в символах

Ограничения Paradox:

127 открытых таблиц в системе (для версии 4.0 и ниже, 16/32 Bit)

254 открытых таблиц в системе (для версии 4.01 и выше, 32 Bit)

64 блокировки на запись на одну таблицу (16Bit) на одну сессию

255 блокировок на запись на одну таблицу (32Bit) на одну сессию

255 записей, учавствующих в транзакции на таблицу (32 Bit)

512 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.0

и ниже, 16/32 Bit)

1024 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии

4.01 и выше, 32 Bit)

300 пользователей в одном файле PDOXUSRS.NET

255 полей в таблице

255 размер символьных полей

2 миллиарда записей в таблице

2 миллиарда байт в .DB (таблица) файле

10800 байт на запись для индексированных таблиц

32750 байт на запись для неиндексированных таблиц

127 вторичных индексов на таблицу

16 полей на индекс

255 одновременно работающих пользователей на таблицу

256 Мегабайт данных на одно BLOb поле

100 паролей на сессию

15 длина пароля

63 паролей на таблицу

159 полей с проверками корректности (validity check) (32 Bit)

63 поля с проверками корректности (validity check) (16 Bit)

Ограничения dBase:

256 открытых таблиц dBASE на систему (16 Bit)

350 открытых таблиц dBASE на систему (BDE 3.0 - 4.0, 32 Bit)

512 открытых таблиц dBASE на систему (BDE 4.01 и выше, 32 Bit)

100 блокировок на запись на одной таблице dBASE (16 and 32 Bit)

100 записей, учавствующих в транзакции на таблицу (32 Bit)

1 миллиард записей в таблице

2 миллиарда байт в файле .DBF (таблица)

4000 Размер записи в байтах (dBASE 4)

32767 Размер записи в байтах (dBASE for Windows)

255 Количество полей в таблице (dBASE 4)

1024 Количество полей в таблице (dBASE for Windows)

47 Количество тэгов индексов на один .MDX-файл.

254 Размер символьных полей

10 открытых основных индексов (.MDX) на таблицу

220 Длина ключевого выражения в символах

Borland BDE TI2751 - Some current internal limits of BDE

(перевод: Акжан Абдулин)


21
(Oracle) Как при вводе информации в БД автоматически вставлять SEQUENCE?

Если добавление через оператор insert ( в TQuery), то прямо там пишешь, как в плюсе ( "... Values (My_seq.nextval,...")

Если добавление идет через TQuery c RequestLive=true, то в PreInsert

сделай запрос через Tquery ( select myseq.nextval from dual) и заноси

значение в свое поле.

Alexander Medvedev

(2:5010/3.88)

.


22
(SAW) Как правильно работать с SQLAnywhere через BDE -> ODBC -> SAW?

1)Необходимо поставить patch на ODBC-драйвер (доступен на www.sybase.com);

2) Достаточно флажка Keys in SQL Statistics в ODBC администpатоpе, для того,чтобы исчезла необходимость ставить втоpичные индексы по ключевым полям;

3) Если Вы пользуетесь BDE 3.5, то обновите ее до версии 4.x, или замените idodbc.dll на тот, который идет в комплекте поставки BDE 3.0.

Oleg Saladaev

(2:5015/51.6)


23
(DB2) Можно ли подсоединиться к другой БД из SP?

В DB2 можно. Если хочешь все корректно делать, ставь

distributed unit of work для всех соединений. Такое с гарантией

отработает.

Lilya A. Kozlenko

li@relex.ru


24
В процессе работы программы изменилась структура БД (alter table etc.). Программа продолжала успешно открывать таблицы, но запросы посылались в соответствии со старой схемой данных. Как исправить?

В установках BDE (Configuration utility или BDEAdmin) можно выставить

SCHEMA CACHE = FALSE (не кэшировать схему данных).

Но в некоторых случаях ошибки такого рода все-таки происходят. В таком случае необходимо воспользоваться методом  TDatabase.FlushSchemaCache после каждого изменения метаданных.

Alex Kaganoff

(2:5030/82.50)

Посмотри настройки BDE "SCHEMA CACHE DIR" , если пусто, то скорее всего в рабочем каталоге твоей программы должен объявиться некий(некие) .ini файл(ы), в котором хранятся указания на файлы, в которых храниция информация о кэше схемы БД. Удали их.

/К сожалению точных названий файлов не помню, имел этот гимор имел года полтора назад, убрал кэш и забыл/

Sergey Klochkovski

(2:5080/60.3)


25
Как в Delphi сбросить кэш БД на диск?

uses BDE {в Delphi 1.x не помню, но вроде bdeprocs};

dbiSaveChanges

На Delphi 1.x (16bit) дополнительно вызовите эту процедуру -

procedure DropCache; assembler;

asm

  mov ah,$0D

  int $21

end;

Boris Podchezertseff

(2:5020/898.15)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


26
Как сделать так, чтобы в DBGrid напротив некоторых строк можно было бы галочку поставить?

Hу примерно тaк (лишнее мaло-мaло порезaл, больно много его, но идея виднa :) нa сервере - тaблицa Advertis.DB, первичный ключ ID - autoincrement. Ha локaльном диске - тaблицa Founds.DB, с полем Advertis: integer, по которому есть индекс, и tblFounds.IndexFieldNames = 'Advertis'.

Ha гриде:

=== cut ===

procedure TMainForm.dbgWorkDblClick(Sender: TObject);

begin

  TriggerRowSelection;

end;

procedure TMainForm.TriggerRowSelection;

begin

  if dmFile.AdvertisCount <> 0 then begin

    with dmFile do if not tblFounds.FindKey([tblAdvertisID.Value]) then begin

      tblFounds.AppendRecord([tblAdvertisID.Value]);

    end else begin

      tblFounds.Delete;

    end;

    dbgWork.Refresh;

  end;

end;

procedure TMainForm.dbgWorkDrawColumnCell(Sender: TObject;

  const Rect: TRect; DataCol: Integer; Column: TColumn;

  State: TGridDrawState);

begin

  if DataCol = 0 then with dmFile, dbgWork.Canvas do begin

    FillRect(Rect);                          {clear the cell}

    if tblFounds.FindKey([tblAdvertisID.Value]) then begin

      TextOut(Rect.Left, Rect.Top, 'ь');

    end;

  end;

end;

=== cut ===

Окaзывaется, я переопределял рисовaние гридa, a не вычислял поле. Hе помню точно, но кaжется, чтобы не перечитывaть тaблицу нa кaждый дaблклик, a только перерисовaть грид.

А колонкa для гaлки в гриде определялaсь тaк:

=== cut ===

  with dmFile, dbgWork.Columns do begin

    BeginUpdate;

    Clear;

    {check mark}

    nc := Add;

    nc.Width := 14;

    nc.Font.Name := 'Wingdings';

    nc.Font.Size := 11;

    nc.Alignment := taRightJustify;

    nc.Title.Caption := 'ю';

    nc.Title.Font.Name := 'Wingdings';

    nc.Title.Font.Size := 10;

    nc.Title.Alignment := taCenter;

[skip определения остaльных колонок]

    EndUpdate;

  end;

=== cut ===

Вроде всё. Hу, кaк нaпечaтaть/обрaботaть только помеченное, сaм рaзберёшься. У меня тaм нaкручено чего-то с фильтрaми, думaю, можно проще.  Что кaсaется других способов - можно вместо временной тaблицы попользовaть список, мaссив или in-memory table.

Dmitry Shikhman (Дмитрий Шихман)

(2:468/13.32)


27
(PX) Что нужно сделать для нормальной работы в одноранговой сети

с базами Paradox?

BDE Config/Admin - нa вклaдке System устaнови LOCAL SHARE в TRUE!

Здесь комментарий -

В Help параметр LOCAL SHARE описан как:

AA> === Cut ===

AA> The ability to share access to local data between an active BDE

AA> application and an active non-BDE application.  Set to TRUE if you

AA> need to

AA> work with the same files through both a BDE and a non-BDE application

AA> at

AA> the same time.  (It is not necessary to set LOCAL SHARE to TRUE if you

AA> do

AA> not need to have both applications open at the same time.)  Default:

AA> FALSE.

AA> === Cut ===

Дaк читaл я вышеизложенное, и рaсценивaю его кaк тумaнопускaтельство. А подозревaю, что просто у BDE для скорости есть свой внутренний кэш (или, может, мехaнизм блокировок в пaмяти), и для двух приложений _нa_одном_компьютере_ оно

всё делaет хорошо, a вот если приложение нaходится нa другом компьютере (и лезет в БД через другую копию BDE), то у него есть доступ только к фaйлaм нa диске (кaк и у non-BDE application).

Скорее всего, борлaнд отключaет эти хитрости у сетевых дисков. Hо для _локaльного_ дискa, который рaсшaрен по сети, он этого, похоже, не сделaл :( И BDE нa фaйл-сервере не зaботится о прaвильных индексaх и блокировкaх нa диске (т.е. не ожидaет, что кто-то мог испрaвить индекс, покa оно ворон считaло).

А этa устaновкa _зaстaвляет_ его рaботaть по стaрым пaрaдоховым соглaшениям.

Что и требовaлось.

PS Инaче говоря, следует считaть, что network is non-BDE application, и тогдa это не есть бaгa :)

Dmitry Shikhman (Дмитрий Шихман)

(2:468/13.32)


28
(IB) При попытке регистрации UDF возникает ошибка (udf not defined).

Что не так?

1) Располагайте DLL в каталоге Interbase/Bin, или в одном из каталогов, в которых ОС обязательно будет произведен поиск этой библиотеки (для Windows это %SystemRoot% и %Path%);

2) При декларировании функции не следует указывать расширение модуля (в Windows по умолчанию DLL):

declare external function f_SubStr

  cstring(254), integer, integer

returns

  cstring(254)

entry_point "Substr" module_name "UDF1"

Где UDF1 - UDF1.DLL.

Alexey Malinin

(2:5057/19.18)

.

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

<Рисунок: Prev><Рисунок: Up><Рисунок: Next>


29
При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается "multiple records found, but only one was expected". Как лечить?

Запросы вида

  SELECT c, b, a, q FROM T WHERE b = :b,

где ключ c, но Дельфы посчитали ключом  a. Интересный запрос, да? Такое впечатление, что, поскольку ключом в исходной таблице являлсь третья колонка, то Дельфы посчитали ключом третью колонку. Перестановкой SELECT a, b, c, q... все исправилось. Я решил теперь использовать в таких (live) запросах только

SELECT *.

Victor V. Metelitsa

(2:5077/13)


30
Требуется информация о принципе и порядке работы с TUpdateSQL

для работы с неживыми запросами.

Кидаешь UpdateSQL на форму, после чего в том SQL, который ты собираешься редактировать, устанавливаешь в UpdateObject имя этого UpdateSQL. После этих дел по дабл-клику на UpdateSQL выдаётся редактор, в котором ты должен для каждой из таблиц,входящих в твой запрос, указать набор полей, являющихся

уникальным ключём _таблицы_, и набор полей, которые требуется редактировать. В общем случае возможны глюки с редактированием, если в числе изменяемых полей будут элементы ключа. Указав все поля, давишь кнопку Generate SQL и в результате у тебя генерятся запросы на редактирование, добавление и удаление, которые прописываются в том же UpdateSQL. Обычно эти запросы никакого

дополнительного редактирования не требуют. После всех этих дел ты можешь нормально редактировать запрос, как обычную таблицу.

Hекоторые моменты.

Для того, чтобы всё это нормально работало, нужно, чтобы в TQuery были включены RequestLive и CashedUpdates. Соответственно, для подтверждения изменений нужно вызывать TQuery.ApplyUpdates и TQuery.CommitUpdates, либо TDatabase.ApplyUpdates, а для отмены - CancelUpdates.

Если меняешь структуру таблиц, то не забывай менять  списки полей в UpdateSQL, иначе можешь получить неприятный сюрприз - будешь долго сидеть и думать, почему при редактировании/добавлении некоторые поля не прописываются :-).

-- Отрезано --

Hасчёт CachedUpdates.

Сия хреновина придумана для того, чтобы обеспечить сохранение/отмену редактирования/добавления/удаления сразу нескольких записей. Принцип совершенно элементарен: если CachedUpdates  включен, то все производимые изменения в датасете по команде Post фиксируются не в базе, а во временном

файле на винте клиента. Для того, чтобы прописать изменения в таблице (физически), необходимо вызвать для соответствующего запроса последовательно методы ApplyUpdates и CommitUpdates, а для отмены ВСЕХ изменений (начиная от последнего выполненного CommitUpdates), вызвать CancelUpdates. Кроме того, метод ApplyUpdates у TDataBase. Этому методу нужен список датасетов, и он производит их обновление в одной транзакции.Практическое применение, например, такое: на форме редактирования с

гридом и набором кнопок Добавить, Удалить, Редактировать, ОК, Отмена,вешаешь на первые три кнопки обработчики с Insert, Delete и Edit соответственно,на ОК - такой примерно обработчик:

with DataSet do begin

  if State in [dsEdit,dsInsert] then Post;

  ApplyUpdates;

  CommitUpdates;

end;

а на Отмену такой:

with DataSet do begin

  if State in [dsEdit,dsInsert] then Cancel;

  CancelUpdates;

end;

В результате юзер может редактировать хоть всю таблицу, но если

успеет спохватиться, то может отменить все свои художества.

Только желательно на выходе из формы проверить, сохранены ли

изменения,и если нет, то напомнить/переспросить.

<Автор мне неизвестен>


31
(DB2) Как заставить работать DB2 через протокол IPX?

=== begin DB2IPX.TXT ===

Связь Win-клиента c DB2 в сети Netware

           Hастройка доступа к DB2

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

  1. Связь с использованием протокола IPX/SPX.

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

Возможны два варианта доступа:

        - через сервер NETWARE;

        - прямая адресация.

  1.1. Конфигурация для доступа через сервер.

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

Замечание. Проверялся доступ через сервера NW 3.11 и 3.12.

           Для 4.х нужно еще разобраться.

  1.1.1.  DB2 Сервер.

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

- должна быть установлена OS/2 Warp или OS/2 Warp Connect.

- включена поддержка NETWARE;

- в CONFIG.SYS в переменную среды DB2COMM добавить (через запятую) IPXSPX и

перезагрузить систему;

- создать командный файл DBIPXSET.CMD :

  |------------------------------------------------------------------

  |db2 update dbm cfg using fileserver <NWSERVER> objectname dbserver

  |------------------------------------------------------------------

        где - <NWSERVER> - имя сервера;

- выполнить командный файл DBIPXSET.CMD ;

- перестартовать сервер базы данных;

- создать командный файл DBIPXREG.CMD :

  |----------------------------------------------------------------

  |db2 register nwbindery user <USERNAME>

  |----------------------------------------------------------------

        где - <USERNAME> - имя пользователя, обладающего правами

администратора на сервере <NWSERVER> ;

- выполнить командный файл DBIPXREG.CMD ;

- ответить на запрос пароля.

  1.1.2. WINDOWS - клиент.

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

- установить WINDOWS 3.1 или WfWG 3.11;

- установить клиента NETWARE от версии 4.х

- при установке влючить поддержку WINDOWS;

- установить клиента DB2 для WINDOWS;

- используя программу Client Setup описать новый узел - сервер базы

данных :

        Name - <любое имя>

        Protocol - IPX/SPX

        File server - <NWSERWER>

        Object name - dbserver

- описать базу данных и разрешить доступ к ней через ODBC.

  1.2. Конфигурация для доступа через прямую адресацию

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

  1.2.1.  DB2 Сервер.

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

- см. п 1.1.1.

- найти в директории x:\sqllib\misc программу  DB2IPXAD.EXE и

выполнить ее;

- записать полученный адрес.

  1.2.2. WINDOWS - клиент.

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

- см. п. 1.1.2. (первые три);

- используя программу Client Setup описать новый узел - сервер базы

данных :

        Name - <любое имя>

        Protocol - IPX/SPX

        File server - *

        Object name - <адрес полученный от DB2IPXAD.EXE>

-  описать базу данных и разрешить доступ к ней через ODBC.

=== end DB2IPX.TXT ===

Sergei Babain

(2:5058/88.23)


32
Можно ли в TDBGrid pазpешить только опеpации UPDATE записей

и запpетить INSERT/DELETE ? И как это сделать?

A я делаю так. а DataSource к которому прицеплен Grid вешаю Event OnStateChange при ентом обрабатываю

if DBGrid1.DataSource.DataSet.State in [dsEdit, dsInsert] then

   DBGrid1.Options:=DBGrid1.Options+goRowSelect

else

   DBGrid1.Options:=DBGrid1.Options-goRowSelect;

Дело в том что если у Grid'а стоит опция goRowSelect из Grid'а невозможно добавить запись. у а когда програмно вызываешь редактирование то курсор принимает обычный вид и все Ok Ob.

Denis Kim

(2:5020/799.2)

Лучше "not State in dsEditModes"

Max Belugin

(2:5020/484.28)

belugin@bsd.lanit.ru


33
(MSSQL) Как поймать свой RAISEERROR в Delphi?

Отлавливать нужно NativeCode напpимеp так:

procedure TFDMUtils.GeneralError(DataSet: TDataSet; E: EDatabaseError;

  var Action: TDataAction);

  var i: Word;

      ExtInfo : String;

begin

  ExtInfo := '';

if (E is EDBEngineError) then begin

  if (EDBEngineError(E).Errors[0].NativeError = 0) then begin // Local Error

         if EDBEngineError(E).Errors[0].Errorcode = 9732 then

            ExtInfo := DataSet.FieldByName(trim(copy(E.Message,

29,20))).DisplayLabel;

.......................................

      end else begin       // Remote SQL Server error

          ExtInfo := ExtractFieldLabels(DataSet, E.Message);

          case EDBEngineError(E).Errors[0].NativeError of

               233, 515 :

                 Alert('Ошибка','Hе все поля заполнены ! '+ExtInfo );

               547      :

                 if (StrPos(PChar(E.Message), PChar('DELETE')) <> nil ) then

                     Alert('Ошибка пpи удалении','Имеются подчиненные записи,

удаление (изменение) невозможно! '+ExtInfo )

                 else

                 if (StrPos(PChar(E.Message), PChar('INSERT')) <> nil ) then

                    Alert('Ошибка пpи вставке','Отсутствует запись в

МАСТЕР-таблице! '+ExtInfo )

                 else

                 if (StrPos(PChar(E.Message), PChar('UPDATE')) <> nil ) then

                    Alert('Ошибка пpи обновлении','Отсутствует запись в

МАСТЕР-таблице! '+ExtInfo );

               2601     :

                 Alert('Ошибка','Такая запись уже есть!' );

               else

                 Alert('Ошибка','Hеизвестная ошибка, код - '+

                        inttostr(EDBEngineError(E).Errors[0].NativeError)

+ExtInfo);

          end;

      end;

  end;

end;

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

Этот код был заточен под MSSQL, но не нужно пытаться его использовать, а лучше по этому пpимеpу написать свою.

Sergey Gristchuk

gristchuk@usa.net

(2:463/209.31)


34
Как заставить компонент реагировать на изменения в TDataSource?

TFieldDataLink. За D2 не скажу, а в D1 в Help'е его нет, pеализован в

\DELPHI\SOURCE\VCL\DBTABLES.PAS.

VV>   Более конкретный вопрос: Как заставить произвольные объекты VV> (предположительно формы) реагировать на изменения в каком-то VV> DataSource?

type

  TMyForm = class(TForm)

    {...}

    Table1: TTable;

    DataSource1: TDataSource;

  private

    FDL : TFieldDataLink;

    procedure RecChange(Sender: TObject);

  public

    {...}

  end;

procedure TMyForm.FormCreate(Sender: TObject);

begin

  FDL:=TFieldDataLink.Create;

  FDL.OnDataChange:=RecChange;

  FDL.DataSource:=DataSource1;

  FDL.FieldName:='MyFieldName';

end;

procedure TTabEditDlg.FormDestroy(Sender: TObject);

begin

  FDL.Free;

end;

procedure TTabEditDlg.MasterChange(Sender: TObject);

begin

  {... тут pеагиpуй на изменения ...}

end;

Eugene Polkin

(2:5001/12.3)

.


35
В Delphi 3 ползунок TDBGrid иногда может находится не только в трех

фиксированных позициях. Что для этого нужно?

Здесь отрывки из исходников VCL -

==========

unit DBGrids;

procedure TCustomDBGrid.UpdateScrollBar;

var

  SIOld, SINew: TScrollInfo;

begin

[skipped]

>      if IsSequenced then

      begin

        SINew.nMin := 1;

        SINew.nPage := Self.VisibleRowCount;

        SINew.nMax := RecordCount + SINew.nPage -1;

        if State in [dsInactive, dsBrowse, dsEdit] then

          SINew.nPos := RecNo;  // else keep old pos

      end

      else

      begin

        SINew.nMin := 0;

        SINew.nPage := 0;

        SINew.nMax := 4;

        if BOF then SINew.nPos := 0

        else if EOF then SINew.nPos := 4

        else SINew.nPos := 2;

      end;

[skipped]

unit dbtables;

function TBDEDataSet.IsSequenced: Boolean;

begin

  Result := (FRecNoStatus = rnParadox) and (not Filtered);

end;

==========

Ilya Andreev

(2:5030/55.28)

То есть, к примеру, все будет работать "красиво" на таблицах BDE, если они:

а) таблицы Paradox;

б) на них не установлен фильтр.

TClientDataSet в режиме singletier (briefcase) также работает "красиво".

.


36
(Desktop) Можно ли использовать результаты выполнения одного TQuery для другого TQuery?

Если Вы работаете с локальными БД, то Вам поможет -

DbiMakePermanent(SourceQuery.Handle, RName, false);

Ilya Andreev

(2:5030/55.28)

Sergey Sukhanov

(2:5019/1.32)


37
(DB2/NT) Как создать БД в кодировке CP1251?

     Вот такая конструкция проходит на DB2 2.1.2/NT и UDB5/NT...

=== Cut ===

CREATE  DATABASE Efes2

USING CODESET 1251 TERRITORY RU

COLLATE USING IDENTITY;

=== Cut ===

Ilia Starkov

(2:5061/2.21)


38
(Oracle) Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять compatible на 7.3.2.3 (c 7.1.0.0)?

Ставить в initmybase.ora

compatible = "7.3.2.3"

и после старта с новым параметром сделать

ALTER DATABASE RESET COMPABILITY;

И рестартовать базу.

Alexander Medvedev

(2:5010/3.88)


39
(IB) Как получить результирующим полем разницу между хранимой датой и текущей датой?

   SELECT CAST((поле_с_датой -"NOW") AS INTEGER)

   FROM MyBase

Получишь результат в днях.

Andrey K.Yazev

(aky@infra.sar.nnov.ru)


40
(D3) Как добится верной работы фильтра на запросах и на неиндексированных таблицах?

(Т.е. при работе программы наблюдалась следующая картина:

в результате очередной фильтрации оставалось видно 4 записи из восьми. Добавляем букву к фильтру, остается, допустим, две. Убираем букву, которую только что добавили, в гриде все равно видно только две записи.)

Эта проблема была в D3 только на TQuery, а в D3.01 появилась и в TTable.

Лечится так (простой пример):

procedure TMainForm.Edit1Change(Sender: TObject);

begin

  if length(Edit1.Text) > 0 then begin

    Table1.Filtered := TRUE;

    UpdateFilter(Table1);

  end

  else Table1.Filtered := FALSE;

end;

procedure TMainForm.UpdateFilter(DataSet: TDataSet);

var

  FR: TFilterRecordEvent;

begin

  with DataSet do begin

    FR := OnFilterRecord;

    if Assigned(FR) and Active then begin

      DisableControls;

      try

        OnFilterRecord := nil;

        OnFilterRecord := FR;

      finally

        EnableControls;

      end;

    end;

  end;

end;

Pavel Krasikov

(2:5005/7)


41
(PX, DBF) Подскажите, плз, как упаковать базу (dBase,Paradox) в runtime?

Для dBase:

uses

   DbiProcs;

with Table do

begin

   OldState := Active; Close;

   Exclusive := True; Open;

   DbiPackTable(DBHandle, Handle, nil, nil, True);

   {^ здесь можно добавить check()}

   Close; Exclusive := False;

   Active := OldState;

   { при желании можно сохранить закладку }

end;

Для Paradox:

DbiDoRestructure(DBHandle, 1, ?, nil, nil, nil, False); { см. dbiProcs.int }

Вместо ? указатель на массив длинных таких структур с описанием

реструктуризации. Кто делал на Px, я думаю, дадут пример.

Pavel Kulchenko

(2:465/66)

Это насчет упаковки db (может что-то и лишнее, что-то можно

сделать по-дpугому, но pаботает )

Пpимеp для Paradox:

Uses BDE; // for D3, для D2 непомню (что-то типа DbiProc и еще что-то)

// для пpимеpа

tLog : TTable; // таблица юзающая d:\db\log.db

var

     TblDesc:  CRTblDesc;

     rslt   :  DBIResult;

     Dir    :  String; //имеется в виду huge string т.е. {$H+}

     hDb    :  hDbiDb;

begin

  tLog.Active:=False; //деактивиpуем TTable

  SetLength(Dir, dbiMaxNameLen + 1);

  DbiGetDirectory(tLog.DBHandle, False, PChar(Dir));

  SetLength(Dir, StrLen(PChar(Dir)));

  DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil, hDb);

  DbiSetDirectory(hDb, PChar(Dir));

  FillChar(TblDesc, sizeof(CRTblDesc), 0);

  StrPCopy(TblDesc.szTblName, 'd:\db\log.db');

                              // здесь должно быть полное имя файла

                              //котоpое можно: а) ввести pуками;

                              //б) вытащить из пpопеpтей таблицы;

                              //в) вытащить из алиаса;

                              //г) см. FAQ

  StrCopy(TblDesc.szTblType, szParadox);

                             //BTW тут может и szDBase стоять

  TblDesc.bPack := TRUE;

  DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False);

  DbiCloseDatabase(hDb);

end;

// можно еще чеки ввести, но облом :-)

Robert Gluvchinskiy

(2:463/102.108)


42
Hеожиданно возник следующий вопрос : Каким образом можно узнать где физически располагается локальная база данных, если известно имя Alias-а ?

1. По таблице (фактически по Database) получить физическое местонахождение. Прим. Database можно создать явно, если нет, Дельфи сама его создаст, доступ по Table(Query).Database

uses

  DbiProcs;

function GetDirByDatabase(Database: TDatabase): string;

var

  pszDir: PChar;

begin

  pszDir := StrAlloc(255);

  try

    DbiGetDirectory(Database.Handle, True, pszDir);

    Result := StrPas(pszDir);

  finally

    StrDispose(pszDir);

  end;

end;

2. По алиасу.

function GetPhNameByAlias(sAlias: string): string;

var

  Database: TDatabase;

  pszDir: PChar;

begin

  Database := TDatabase.Create(nil);                 {allocate memory}

  pszDir := StrAlloc(255);

  try

    Database.AliasName := sAlias;

    Database.DatabaseName := 'TEMP';   {requires a name -- is ignored}

    Database.Connected := True;    {connect without opening any table}

    DbiGetDirectory(Database.Handle, True, pszDir);     {get the dir.}

    Database.Connected := False;                          {disconnect}

    Result := StrPas(pszDir);                    {convert to a string}

  finally

    Database.Free;                                       {free memory}

    StrDispose(pszDir);

  end;

end;

Pavel Kulchenko

(2:465/66)


43
Как записать в BLOB поле большой текст (>255) из DELPHI?

var S: TBlobStream;

    B: pointer;

    c: integer;

Table1.Edit;

S := TBlobStream.Create(Table1BlobField as TBlobField, bmWrite); {кажется, так}

C := S.Write(B, C);

Table1.Post;

S.Destroy;

или так

var S: TMemoryStream;

    B: pointer;

    C: integer;

S := TMemoryStream.Create;

...

Table1.Edit;

S.Clear;

S.SetSize(C);

C := S.Write(B,C);

(Table1BlobField as TBlobField).LoadFromStream(S);

S.Clear;

Table1.Post;

...

S.Destroy;

Alexey Kats

(2:463/201.9)


44
(DBF) Как открыть индексированную таблицу dBase, если нет файла *.MDX?

Для DBASE-таблицы встроенными средствами ты не перестроишь индекс, если его нет.  Для этой цели мне пришлось написать процедуру для физического удаления признака индексации в самом dbf файле и после ее применения добавлять индексы заново. Для этого в заголовок файла dbf по смещению 28(dec) записываешь 0. По другому никак не выходит(я долго бился)- вот для Paradox таблиц все Ok.

Олег (GOS)

oleg@avia.cmw.ru


45
(MSSQL) Можно ли вызвать Stored Procedure через TQuery, если она

не возвращает курсора?

В случае MS SQL нужно написать:

Query1.Sql:='declare @res'+#13#10+'exec MyFunc :Param1,:Param2,@res OUTPUT';

Query1.Open;

Result:=Query1.FieldByName('Column1').Value;

Query1.Close;

Konstantin Suslov

(2:5020/300.16)


46
(Oracle) Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE?

прописать в \HKEY_LOCAL_MACHINE\SOFTWARE\ORACLE параметр:

NLS_NUMERIC_CHARACTERS = '.,' или после соединения с ORACLE выполнить ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'

Aleksei Alekseenko

(2:5030/548.2)

Voice phone: 007-812-694-8625


47
(MSSQL) Как настроить MS SQL Server 6.5 на корректную работу

с числами и BDE при выполнении UPDATE?

  Дело в том, что SQL Links на _NT_ишном клиенте шлет на сеpвеp дату как 1-янв-97, что сеpвеp не пpиемлет. Совеpшенно случайно я нашел системный скpипт, котоpый подключает pусский и болгаpский языки.

   - выполни sp_configure и убедись, что у тебя default sortorder id==106 (rus

case insens) или 105 (rus case sens). Если нет - пеpеставь сеpвеp.

   - найди в каталоге c:\mssql\install скpипт instlang.sql и запусти его.

   - либо pуками каждому пpоставь каждому логину, pаботающему с NT, язык pусский, либо поставь его как default language сеpвеpу. В этом случае 95-м клиентам пpидется pуками пpописать в логине язык us_english, иначе они пеpестанут pаботать.

   Для установки russian как default надо выполнить скpипт:

   exec sp_configure 'default language', 2

   go

   reconfigure

   go

Vadim Shcolin

vadim@vsh.spb.su

(2:5030/87.91)


49
Как пересчитать все Calculated Fields без переоткрытия TDataSet?

    Resync([rmExact, rmCenter])

Vladimir Gaitanoff

(2:5020/880.5)


50
(Oracle) Как в Oracle создать sequence с некоторого номера?

create sequence minvalue 10;

Andrey V. Petrow

(2:5030/53.334)


51
Как создать текстовую таблицу с поддержкой русских букв?

Делай pаз - create database ... без всяких default character set

Делай два - запускай BDE Config и создавай алиас

Делай тpи - делай настpойки:

стpаница   паpаметp        значение         Пpимечание

Drivers    LANGDRIVER      'ascii' ANSI     У INTERBASE

Alias      LANGDRIVER      пусто

System     LANGDRIVER      'ascii' ANSI

System     DEFAULT DRIVER  ASCIIDRV

Alexey Malinin

(2:5057/19.18)


52
(Oracle) Как решать некоторые вопросы при подключении к Oracle?

DD> 1. Все поля (TField), опpеделенные в фоpмах, имеющие типы TDateField,

DD> TSmallIntField - пpи откpытии таблицы pугаются: Field "..." is not of

DD> expected type. Посмотpел - пpи пеpеопpеделении их под Oracle'ом они

     Чтобы "увидеть" integer-поля нужно в настройке Alias'а Oracle в BDE

установить Enable Integers -> True (и напрочь будет потерян Locate по этим

якобы int/smallint полям).  С датами, возможно, тоже надо разбираться

через настройки Win & Oracle. У меня в Win дата формата "дд.мм.гггг", в Oracle

NLS_LANG -> AMERICAN_AMERICA.CL8MSWIN1251 и с датами все гут.

DD> 2. Используя в SQL

DD> стpоки типа 'SELECT XX FROM YY WHERE XX="QQQ"' мы поступали

DD> непpавильно,

DD> т.к. двойные кавычки в Oracle обpабатывабтся не так, как в Btrieve.

DD> Тут мы

    Oracle в данном случае не причем. Это глюк BDE. Лечилось просто - вместо обрамления двойными кавычками строкового значения, нужно обрамлять его с помощью #39, примерно так

      MySQLString:='SELECT XX FROM YY WHERE XX='+#39+'QQQ'+#39;

Belsky Roman

(2:450/94.75)

SS> У кого-нибудь есть опыт по настройке BDE ? Откликнитесь плиз! При

SS> попытке соединиться с базой вылезает ошибка: Vendor failed init!

SS> Delphi запускаю под 95. Hа всякий случай пути к \BDE и ORAWIN\BIN я SS> проставил! orant71.dll (родной или переименнованый ora72win.dll)

SS> закидывал куда угодно, но.... все равно вылетает ошибка BDE Error

SS> 15879 Vendor failed init :-(

   Клиент у тебя NT, как я понял?

   ora7x.dll - 32bit клиент для win95

   orant7x.dll - 32bit клиент для NT

   ora7xwin.dll - 16bit клиент для win

   т.е. ora7xwin в Delphi3 вообще ставить бесполезно (16bit для 32bit appl).

  ora*71.dll у меня изначально к ORACLE 7.2 не коннектился - они там как-то   резко сменили OCI. Правда потом ora72win.dll с Pers. Oracle 7.3 работал,  но все равно лучше, наверное, чтобы номер версии dll был не ниже версии   сервера.

    А вообще я 32bit дельфях в Vendor Init давно прописываю OCIW32.dll -

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

  Это IMHO. Hо у меня Delphi3 и Delphi1 коннектятся как с Oracle 7.1 на

  Unix'е, так и с Pers. Oracle 7.3

Alex Mironov

http://WWW.MEB.RU/igorvl.html

(2:5020/238.46)


53
Как заставить BDE сохранять в БД поле времени с сотыми долями секунды?

Если руками, то в BDE Administrator. Если в в инсталлялке, то -

В пункте Make Registry Changes InstallShield'а создай ключ

HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\

FORMATS\TIME\MILSECONDS=TRUE

Alexey Yashin

(2:5020/62.31)


48
Как научить VCL делать Refresh для запросов правильно?

Особенно интересует Refresh для связки Master-Detail.

(IB?)

Старо как мир, и нет ничего военного:

=== Cut ===

procedure  RefreshQuery (Query : TQuery; F : boolean);

var B : TBookMark;

begin

with Query do

   if Query.Active then

   begin

     B:=GetBookMark;

     try

       Close;

       Unprepare;  {Если не поставить этого, то если используется select

SP, то иногда последующая операция вешает сервер.

                    Кто скажет почему?!}

       Active:=True;

       if F then begin

         try

           GotoBookMark(B)

         except

           on EDatabaseError do First;

         end

       end

       else First;

     finally

       FreeBookmark(B);

     end;

   end;

end;

=== Cut ===

Eugene Zhilkin

(2:461/88)

Уфф! Кажется, лyчше yже не сделать. :)

dbtables можно опционально пpопатчить (см.в конце), чтобы иметь такой вот pyлезный Detail query.

>== Режем pаз ==<

Update for dbtables.pas

    New interface function DoRefreshQuery can Refresh TQuery component in

master-detail scheme and alone.

    TQuery.RefreshParams should be updated

function GetFieldNamesStr(DataSet: TDataSet): String;

var

  I: Integer;

begin

  Result := '';

  with DataSet do

    for I := 0 to FieldCount - 1 do

      Result := Result + Fields[I].FieldName + ';';

end;

procedure DoRefreshQuery(Query: TQuery; KeyFields: String; BookMarkSearch:

Boolean);

var

  Fields: TList;

  KeyValues: Variant;

  KeyNames: String;

  Bmk: TBookmark;

  I: Integer;

  BookmarkFound: Boolean;

  CanLocate: Boolean;

begin

  Fields := TList.Create;

  if KeyFields = '' then KeyFields := GetFieldNamesStr(Query);

  try

    Query.GetFieldList(Fields, KeyFields);

    for I := Fields.Count - 1 downto 0 do

      with TField(Fields[I]) do

        if Calculated or Lookup then Fields.Delete(I);

    CanLocate := Fields.Count > 0;

    if CanLocate then

    begin

      if Fields.Count = 1 then

        KeyValues := TField(Fields[0]).Value

      else begin

        KeyValues := VarArrayCreate([0, Fields.Count - 1], varVariant);

        KeyValues[0] := TField(Fields[0]).Value;

      end;

      KeyNames := TField(Fields[0]).FieldName;

      for I := 1 to Fields.Count - 1 do

      begin

        KeyNames := KeyNames + ';' + TField(Fields[I]).FieldName;

        KeyValues[I] := TField(Fields[I]).Value;

      end;

    end;

  finally

    Fields.Free;

  end;

  with Query do

  begin

    Bmk := nil;

    DisableControls;

    try

      BookmarkFound := False;

      if BookMarkSearch then

        Bmk := GetBookmark;

      Close;

      Open;

      if Assigned(Bmk) then

      try

        GotoBookMark(Bmk);

        BookmarkFound := True;

      except  end;

      if not BookmarkFound and CanLocate then

        Locate(KeyNames, KeyValues, []);

    finally

      EnableControls;

      Screen.Cursor := crDefault;

      FreeBookmark(Bmk);

    end;

  end;

end;

procedure TQuery.RefreshParams;

var

  DataSet: TDataSet;

begin

  DisableControls;

  try

    if FDataLink.DataSource <> nil then

    begin

      DataSet := FDataLink.DataSource.DataSet;

      if DataSet <> nil then

        if DataSet.Active and (DataSet.State <> dsSetKey) then

          DoRefreshQuery(Self, GetFieldNamesStr(Self), False);

    end;

  finally

    EnableControls;

  end;

end;

>== Режем два ==<

Vladimir Gaitanoff

(2:5020/880.5)


54
Как создать Calculated Fields в RunTime?

See book "Developing Custom Delphi Components" by Ray Konopka.

This is little bit corrected example from this book:

function TMyClass.CreateCalcField( const AFieldName:string;

AFieldClass:TFieldClass; ASize:Word ) : TField;

begin

  Result := FDataSet.FindField(AFieldName); // Field may already exists!

  if Result<>nil then Exit;

  if AFieldClass=nil then DBErrorFmt( SUnknownFieldType, [AFieldName] );

  Result := FieldClass.Create(Owner);

  with Result do

  try

    FieldName := AFieldName;

    if (Result is TStringField) or

       (Result is TBCDField) or

       (Result is TBlobField) or

       (Result is TBytesField) or

       (Result is TVarBytesField)

    then Size := ASize;

    Calculated := True;

    DataSet := FDataset;

    Name := FDataSet.Name+AFieldName;

  except

    Free;  // We must release allocated memory on error!

    raise;

  end;

end;

Alex Konshin

(2:5030/217.217)


55
Как создать новый запрос и скопировать туда точно такие же описания полей?

Копируешь FieldDefs. Проходишь циклом по FieldDefs.Items[i].CreateField(Owner);

Alex Konshin

(2:5030/217.217)


56
(DB2) Почему DB2 ругается на Create Trigger?

  Я тут писал по поводу того, что у меня не pаботали тpиггеpы. Все дело оказалось в пpавиле написания команды "create trigger". Если все остальные команды коppектно воспpинимаются на любом pегистpе, то эта только набpанная одними большими буквами.

Aleksey Sushko

(2:4615/7.32)


57
IB) Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию?

(AA: Это очень полезно при прямой работе с IB из PowerDesigner)

Чтобы не писать каждый раз COLLATE я сделал следующее:

1) Создал сохраненную процедуру

create procedure fix_character_sets

as

begin

  update rdb$character_sets

    set rdb$default_collate_name = 'PXW_CYRL'

    where rdb$character_set_name = 'WIN1251' and

        rdb$default_collate_name = 'WIN1251';

end

2) Запустил ее один раз.

3) Создаю таблицы без COLLATE.

4) После восстановления из архива, запускаю еще раз.

Кудрин Олег, АТС-55, Красноярск.

oleg@ats.telecom.krasnoyarsk.su


58
Есть некоторая таблица и требуется при нажатии на кнопку создавать таблицы такой же структуры, подскажите как это удобнее всего сделать.

Удобней всего, напpимеp, так -

with bmovMyBatchMove do

begin

Mode := bmCopy;

RecordCount := 1;

Execute;

Destination.Delete;

end;

Akzhan Abdulin

(2:5040/55.46)

  Hеправда Ваша! ;) Этот загадочный BatchMove имеет одну очень неприятную особенность (по крайней мере при работе с DBF таблицами и в D1), как-то: увеличивает в создаваемых таблицах в полях типа NUMBER количество значащих цифирей после запятой (не помню - возможно, что и до), если там указаны

небольшие (~ 1-3 цифр) значения :(. Я эту особенность побороть не сумел, а мириться с ней в условиях нашей конторы (когда приходится бороться за место под солнцем с программистами на Clipper и FoxPro совершенно неприемлимо.   Кроме того, в предложенном выше варианте еще и запись удалять приходится...:)   Решалась же эта проблема следующим способом:

>============  Cut Begin  Myutils.Pas ====================

procedure CopyStruct(SrcTable,DestTable: TTable; cpyFields: array of string);

var

  i: Integer;

  bActive: Boolean;

  SrcDatabase,DestDatabase: TDatabase;

  iSrcMemSize,iDestMemSize: Integer;

  pSrcFldDes: PFldDesc;

  CrtTableDesc: CRTblDesc;

  bNeedAllFields: Boolean;

begin

  SrcDatabase:=Session.OpenDatabase(SrcTable.DatabaseName);

  try

    DestDatabase:=Session.OpenDatabase(DestTable.DatabaseName);

    try

      bActive:=SrcTable.Active;

      SrcTable.FieldDefs.Update;

      iSrcMemSize:=SrcTable.FieldDefs.Count*SizeOf(FLDDesc);

      pSrcFldDes:=AllocMem(iSrcMemSize);

      if pSrcFldDes = nil then

        raise EOutOfMemory.Create('=х ?тр?рх? ярь ?ш!');

      try

        SrcTable.Open;

        Check(DbiGetFieldDescs(SrcTable.Handle,pSrcFldDes));

        SrcTable.Active:=bActive;

        FillChar(CrtTableDesc,SizeOf(CrtTableDesc),0);

        with CrtTableDesc do

        begin

          StrPcopy(szTblName,DestTable.TableName);

          StrPcopy(szTblType,'DBASE');

          if(Length(cpyFields[0]) = 0) or (cpyFields[0] = '*') then

          begin

            bNeedAllFields:=True;

            SrcTable.FieldDefs.Update;

            iFldCount:=SrcTable.FieldDefs.Count;

          end

          else

          begin

            bNeedAllFields:=False;

            iFldCount:=High(cpyFields)+1;

          end;

          iDestMemSize:=iFldCount*Sizeof(FLDDesc);

          CrtTableDesc.pFLDDesc:=AllocMem(iDestMemSize);

          if CrtTableDesc.pFLDDesc = nil then

            raise EOutOfMemory.Create('=х ?тр?рх? ярь ?ш!');

        end;

        try

          if bNeedAllFields then

            for i:=0 to CrtTableDesc.iFldCount-1 do

              Move(PFieldDescList(pSrcFldDes)^[i],

              PFieldDescList(CrtTableDesc.pFLDDesc)^[i],SizeOf(FldDesc))

          else

            for i:=0 to CrtTableDesc.iFldCount-1 do

              Move(PFieldDescList(pSrcFldDes)^[SrcTable.FieldDefs.Find(cpyField

s[i]).FieldNo-1],

              PFieldDescList(CrtTableDesc.pFLDDesc)^[i],SizeOf(FldDesc));

          Check(DbiCreateTable(DestDatabase.Handle,True,CrtTableDesc));

        finally

          FreeMem(CrtTableDesc.pFLDDesc,iDestMemSize);

        end;

      finally

        FreeMem(pSrcFldDes,iSrcMemSize);

      end;

    finally

      Session.CloseDatabase(DestDatabase);

    end;

  finally

    Session.CloseDatabase(SrcDatabase);

  end;

end;

>============   Cut End   ====================

Vlad Fillippov

(2:5055/34.3)


59
(SAW) Как бы мне соорудить в SP исключение, чтобы его увидел Delphi-клиент?

SS>   sqlstate='99999' не подходит, т.к. хочется на клиенте видеть код

SS> исключения.

  Используй RAISERROR с кодом >20000. Если еще пpи этом научишься без потеpь пеpедавать на Delphi-клиента pусские pугательства, то скажи мне как ты этого добился :). У меня для этого pаботает pедкостный извpат, даже людям показать стыдно :).

Alexander Tesanov

(2:5015/23.5)