Удаление колонки в StringGrid
Удаление колонки в StringGrid
Procedure GridRemoveColumn(StrGrid: TStringGrid; DelColumn: Integer);
Var Column: Integer;
begin
If DelColumn <= StrGrid.ColCount then
Begin
For Column := DelColumn To StrGrid.ColCount-1 do
StrGrid.Cols[Column-1].Assign(StrGrid.Cols[Column]);
StrGrid.ColCount := StrGrid.ColCount-1;
End;
end;
procedure RemoveColumn(SG : TStringGrid; ColNumber : integer);
var Column : integer;
begin
ColNumber := abs(ColNumber);
if ColNumber <= SG.ColCount then begin
for Column := ColNumber to SG.ColCount - 2 do begin
SG.Cols[Column].Assign(SG.Cols[Column + 1]);
SG.Colwidths[Column] := SG.Colwidths[Column + 1];
end;
SG.ColCount := SG.ColCount - 1;
end;
end;
Взято с Исходников.ru
Универсальные пароли к BIOS
Универсальные пароли к BIOS
AWARD BIOS v2.50
AWARD_SW
j262
TTPTHA
01322222
KDD
ZBAAACA
aPAf
lkwpeter
t0ch88
t0ch20x
h6BB
j09F
TzqF
AWARD BIOS v2.51
AWARD_WG
j256
BIOSTAR
HLT
ZAAADA
Syxz
?award
256256
alfarome
SWITCHES_SW
Sxyz
SZYX
t0ch20x
AWARD BIOS v2.51G
g6PJ
j322
ZJAAADC
Wodj
bios*
biosstar
h6BB
HELGA-S
HEWITT
RAND
HLT
t0ch88
zjaaadc
AWARD BIOS v2.51U
1EAAh
condo
biostar
CONDO
CONCAT
djonet
efmukl
g6PJ
j09F
j64
zbaaaca
AWARD BIOS v4.5x
AWARD_SW
AWARD_PW
589589
PASSWORD
SKY_FOX
AWARD SW
award.sw
AWARD?SW
award_?
award_ps
ZAAADA
AMI BIOS
AMI
AMI_SW (не унивеpсальный но устанавливается пpи сбpосе CMOS/SETUP'a)
SER
Ctrl+Alt+Del+Ins (держать при загрузке, иногда просто INS) ;)
A.M.I.
aammii
ami.kez
ami°
amiami
AMI!SW
AMI.KEY
AMI?SW
AMISETUP
AMI~
AMIPSWD
amipswd
helgaЯs
bios310
amidecod
BIOSPASS
CMOSPWD
HEWITT RAND
KILLCMOS
AMPTON BIOS
Polrty
AST BIOS
SnuFG5
BIOSTAR BIOS
Biostar
Q54arwms
COMPAQ BIOS
Compaq
CONCORD BIOS
last
CTX International BIOS
CTX_123
CyberMax BIOS
Congress
Daewoo BIOS
Daewuu
Daytek BIOS
Daytec
DELL BIOS
Dell
Digital Equipment BIOS
komprie
Enox BIOS
xo11nE
Epox BIOS
central
Freetech BIOS
Posterie
HP Vectra BIOS
hewlpack
IBM BIOS
IBM
MBIUO
sertafu
Iwill BIOS
iwill
JetWay BIOS
spoom1
Joss Technology BIOS
57gbz6
technolgi
M Technology BIOS
mMmM
MachSpeed BIOS
sp99dd
Magic-Pro BIOS
prost
Megastar BIOS
star
Megastar BIOS
sldkj754
xyzall
Micronics BIOS
dn_04rjc
Nimble BIOS
xdfk9874t3
Packard Bell BIOS
bell9
QDI BIOS
QDI
Quantex BIOS
teX1
xljlbj
Research BIOS
Col2ogro2
Shuttle BIOS
Col2ogro2
Siemens Nixdorf BIOS
SKY_FOX
SpeedEasy BIOS
lesarot1
SuperMicro BIOS
ksdjfg934t
Tinys BIOS
tiny
TMC BIOS
BIGO
Toshiba BIOS
Toshiba
24Banc81
toshy99
Vextrec Technology BIOS
Vextrex
Vobis BIOS
merlin
WIMBIOSnbsp v2.10 BIOS
Compleri
Zenith BIOS
3098z
Zenith
ZEOS BIOS
zeosx
[C] Faraon
Источник: http://wasm.ru
Прислал p0s0l
Unix-строки (чтение и запись Unix-файлов)
Unix-строки (чтение и запись Unix-файлов)
unitStreamFile;
interface
uses SysUtils;
procedure AssignStreamFile(var F: Text; Filename: string);
implementation
const
BufferSize = 128;
type
TStreamBuffer = array[1..High(Integer)] of Char;
TStreamBufferPointer = ^TStreamBuffer;
TStreamFileRecord = record
case Integer of
1:
(
Filehandle: Integer;
Buffer: TStreamBufferPointer;
BufferOffset: Integer;
ReadCount: Integer;
);
2:
(
Dummy: array[1..32] of Char
)
end;
function StreamFileOpen(var F: TTextRec): Integer;
var
Status: Integer;
begin
with TStreamFileRecord(F.UserData) do
begin
GetMem(Buffer, BufferSize);
case F.Mode of
fmInput:
FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone);
fmOutput:
FileHandle := FileCreate(StrPas(F.Name));
fmInOut:
begin
FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone or
fmOpenWrite or fmOpenRead);
if FileHandle <> -1 then
status := FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }
F.Mode := fmOutput;
end;
end;
BufferOffset := 0;
ReadCount := 0;
F.BufEnd := 0; { В этом месте подразумеваем что мы достигли конца файла (eof). }
if FileHandle = -1 then
Result := -1
else
Result := 0;
end;
end;
function StreamFileInOut(var F: TTextRec): Integer;
procedure Read(var Data: TStreamFileRecord);
procedure CopyData;
begin
while (F.BufEnd < Sizeof(F.Buffer) - 2)
and (Data.BufferOffset <= Data.ReadCount)
and (Data.Buffer[Data.BufferOffset] <> #10) do
begin
F.Buffer[F.BufEnd] := Data.Buffer^[Data.BufferOffset];
Inc(Data.BufferOffset);
Inc(F.BufEnd);
end;
if Data.Buffer[Data.BufferOffset] = #10 then
begin
F.Buffer[F.BufEnd] := #13;
Inc(F.BufEnd);
F.Buffer[F.BufEnd] := #10;
Inc(F.BufEnd);
Inc(Data.BufferOffset);
end;
end;
begin
F.BufEnd := 0;
F.BufPos := 0;
F.Buffer := '';
repeat
begin
if (Data.ReadCount = 0) or (Data.BufferOffset > Data.ReadCount) then
begin
Data.BufferOffset := 1;
Data.ReadCount := FileRead(Data.FileHandle, Data.Buffer^, BufferSize);
end;
CopyData;
end until (Data.ReadCount = 0)
or (F.BufEnd >= Sizeof(F.Buffer) - 2);
Result := 0;
end;
procedure Write(var Data: TStreamFileRecord);
var
Status: Integer;
Destination: Integer;
II: Integer;
begin
with TStreamFileRecord(F.UserData) do
begin
Destination := 0;
for II := 0 to F.BufPos - 1 do
begin
if F.Buffer[II] <> #13 then
begin
Inc(Destination);
Buffer^[Destination] := F.Buffer[II];
end;
end;
Status := FileWrite(FileHandle, Buffer^, Destination);
F.BufPos := 0;
Result := 0;
end;
end;
begin
case F.Mode of
fmInput:
Read(TStreamFileRecord(F.UserData));
fmOutput:
Write(TStreamFileRecord(F.UserData));
end;
end;
function StreamFileFlush(var F: TTextRec): Integer;
begin
Result := 0;
end;
function StreamFileClose(var F: TTextRec): Integer;
begin
with TStreamFileRecord(F.UserData) do
begin
FreeMem(Buffer);
FileClose(FileHandle);
end;
Result := 0;
end;
procedure AssignStreamFile(var F: Text; Filename: string);
begin
with TTextRec(F) do
begin
Mode := fmClosed;
BufPtr := @Buffer;
BufSize := Sizeof(Buffer);
OpenFunc := @StreamFileOpen;
InOutFunc := @StreamFileInOut;
FlushFunc := @StreamFileFlush;
CloseFunc := @StreamFileClose;
StrPLCopy(Name, FileName, Sizeof(Name) - 1);
end;
end;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
Unresolved external malloc referenced, Ошибка
Unresolved external malloc referenced, Ошибка линкера Kylix 3
Ошибкавозникает на Kilyx 3 (C++ IDE) установленном на новых версиях Linux.
Требуется установить специальный Патч
Автор:
VitВзято из
Управление игрой FreeCell
Управление игрой FreeCell
Если вы решили перепробовать ВСЕ номера игры FreeCell, вас можно квалифицировать как законченного маньяка. В этом случае вас, возможно, заинтересует эта маленькая программка. При ее запуске она загружает FreeCell и начинает игру, следующую за той, которую вы не смогли завершить в прошлый раз. А еще она отвечает на глупые вопросы типа "Do you really want to resign the game?". После выигрыша программа изменяет счетчик таким образом, чтобы при очередном запуске номер игры изменялся на следующий автоматически.
Для создания программы расположите на новой форме таймер, установите ее свойство WindowState на wsMinimized и используйте следующий код:
...
private
{ Private declarations }
InstHandle: Word;
WndHandle: hWnd;
NextGame: Word;
function EnumFunc(H: HWnd): Word;
procedure WMQUERYOPEN(var Msg: TWMQueryOpen); message WM_QUERYOPEN;
...
interface
USES
ShellApi, IniFiles;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
H, SubH: hMenu;
NewGameID: Word;
FreeCellPath: string;
begin
with TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) do
try
FreeCellPath := ReadString('FreeCell', 'Path',
'C:\WIN32APP\FREECELL\FREECELL.EXE') + #0;
NextGame := ReadInteger('FreeCell', 'NextGame', 1);
finally
Free;
end;
InstHandle := ShellExecute(Handle, nil, @FreeCellPath[1],
nil, nil, SW_SHOW);
WndHandle := 0;
if InstHandle >= 32 then
EnumWindows(@TForm1.EnumFunc, LongInt(Self));
if WndHandle <> 0 then
begin
{Вычисляем ID пункта меню "Select Game"}
H := GetMenu(WndHandle);
SubH := GetSubMenu(H, 0);
NewGameID := GetMenuItemID(SubH, 1);
Winprocs.SetFocus(WndHandle);
{вызываем "Select Game"}
PostMessage(WndHandle, WM_COMMAND, NewGameID, 0);
Timer1.Enabled := True;
end
else
Close;
end;
procedure TForm1.WMQUERYOPEN(var Msg: TWMQueryOpen);
begin
Msg.Result := 0;
end;
function TForm1.EnumFunc(H: HWnd): Word;
begin
if GetWindowWord(H, GWW_HINSTANCE) = InstHandle then
begin
WndHandle := H;
Result := 0;
end
else
Result := 1;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
Buffer: array[0..10] of Char;
DlgHandle: Word;
begin
{Если пользователь закрыл FreeCell, выходим!}
if GetModuleUsage(InstHandle) = 0 then
begin
Close;
Exit;
end;
{При необходимости укажите номер игры}
DlgHandle := FindWindow('#32770', 'Game Number');
if DlgHandle <> 0 then
begin
Str(NextGame, Buffer);
SendDlgItemMessage(DlgHandle, $CB, WM_SETTEXT,
0, LongInt(@Buffer));
PostMessage(DlgHandle, WM_COMMAND, 1,
MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED));
end;
{Если игра окончена, увеличиваем счетчик}
DlgHandle := FindWindow('#32770', 'Game Over');
if DlgHandle <> 0 then
begin
Inc(NextGame);
with TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) do
try
WriteInteger('FreeCell', 'NextGame', NextGame);
finally Free;
end;
PostMessage(DlgHandle, WM_COMMAND, 6,
MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED));
end;
{Если игра спрашивает, хотите ли вы выйти, отвечем соответственно yes или OK}
DlgHandle := FindWindow('#32770', 'FreeCell');
if DlgHandle <> 0 then
begin
if (not (GetDlgItemText(DlgHandle, 6, Buffer, 10) in [0, 10]))
and (StrComp(Buffer, '&Yes') = 0) then
PostMessage(DlgHandle, WM_COMMAND, 6,
MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED))
else if (not (GetDlgItemText(DlgHandle, 2, Buffer, 10) in [0, 10]))
and (StrComp(Buffer, 'Cancel') = 0) then
PostMessage(DlgHandle, WM_COMMAND, 1,
MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED))
end;
end;
Взято с
Управление настройками шрифта
Управление настройками шрифта
{
Данныйкод изменяет стиль шрифта поля редактирования,
если оно выбрано. Может быть адаприрован для управления
шрифтами в других объектах.
Расположите на форме Edit(Edit1) и ListBox(ListBox1).
Добавьте следующие элементы (Items) к ListBox:
fsBold
fsItalic
fsUnderLine
fsStrikeOut
}
procedure TForm1.ListBox1Click(Sender: TObject);
var
X: Integer;
type
TLookUpRec = record
Name: string;
Data: TFontStyle;
end;
const
LookUpTable: array[1..4] of TLookUpRec =
((Name: 'fsBold'; Data: fsBold),
(Name: 'fsItalic'; Data: fsItalic),
(Name: 'fsUnderline'; Data: fsUnderline),
(Name: 'fsStrikeOut'; Data: fsStrikeOut));
begin
X := ListBox1.ItemIndex;
Edit1.Text := ListBox1.Items[X];
Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex + 1].Data];
end;
Взято из
Управление приложением через Telnet
Управление приложением через Telnet
Итак, начнем с главного - почему для удаленного администрирования своей программы следует использовать именно Telnet? Ответ на этот вопрос достаточно прост:
Утилита Telnet есть на любом компьютере с операционной системой Windows, UNIX, AIX и т.п., поэтому ее не требуется писать или устанавливать
Telnet является штатным средством удаленного администрирования.
Telnet подразумевает текстовый обмен, поэтому его очень легко поддерживать в своей программе
Возможностей текстового терминала как правило достаточно для управления программой, ее настройки и администрирования
Рассмотрим немного теории. Утилиту Telnet легче всего запустить через Start->Run (Пуск -> Выполнить). После запуска необходимо произвести соединение с удаленным хостом, для чего выполняется используется меню "Connect->Remote System". При этом выводится меню соединения, в котором необходимо указать три параметра: хост, порт и тип терминала. В качестве хоста указывается имя удаленного компьютера (или его IP адрес), порт можно задать двумя путями - выбором/вводом символического имени (например, telnet), или вводом номера порта. Мы будем пользоваться вторым путем, т.е. будем использовать нестандартные номера портов. Тип терминала оставим vt100.
Утилита Telnet поддерживает параметры командой строки:
telnet [remote_host] [port]
где
remote_host представляет собой имя или IP адрес удаленной машины.
port номер порта. Если соединение идет по стандартному порту, то этот параметр опускается.
Пример:
telnet zaitsevov или telnet zaitsevov 5000
Протокол Telnet очень прост - сначала устанавливается TCP/IP соединение с удаленной машиной. Затем, когда пользователь вводит символ, происходит его передача удаленному хосту. Для простоты будем называть его сервером.
Далее возможно два режима работы - с локальным эхом или без локального эха (режим по умолчанию). Если работа ведется с локальным эхом, то каждый вводимый пользователем символ немедленно отображается на экране. При работе без локального эха сервер обязан создавать эхо, дублирую принимаемые данные клиенту. Это позволят тестировать канал (каждый символ проходит по кругу) и организовывать ввод данных без эха (например, для ввода пароля). Мои примеры ориентированы на работу без локального эха.
При приеме любой информации от сервера утилита Telnet немедленно отображает его на экране. Это позволяет серверу организовывать эхо и выводить любую информацию в текстовом виде. При этом поддерживатся некоторые управляющие коды, например, код "забой", стирающий один символ.
Итак, приступим к разработке приложения. Создадим пустой проект и поместим на форму компонент ServerSocket1 типа TServerSocket. Зададим ему порт, например 5000. Напоминаю, что:
номер порта должен быть нестандартным, чтобы не пересекаться с другими программами. При этом желательно считывать его из INI файла, что даст возможность настройки при необходимости.
Свойство Active должно быть false и устанавливаться в true при запуске программы. Иначе приложение свалится при попытке запуска второй копии или при отсутствии сети. Установку Active := true следует делать в блоке try ... except
Итак, в обработчике OnCreate формы пишем:
begin
try
ServerSocket1.Active := true;
except
ShowMessage('Ошибки при активации ServerSocket');
end;
end;
Далее необходимо научиться определять моменты соединения и отключения клиента. Для этого следует создать обработчики OnClientConnect и OnClientDisconnect. Сразу отмечу, что при подключении клиента обычно принято выдывать ему заголовок, ообщающий о том, что он соединился с программой *** версии NN. С учетом этого обработчик OnClientConnect будет иметь вид:
procedure TMain.ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.SendText('Connected. Программа Telnet1 Example на проводе.'+#$0D+#$0A);
Socket.SendText('Enter password : ');
Connected := false;
Memo1.Lines.Add('Произошло соединение с пользователем');
end;
При этом я хочу подчеркнуть особенность - нормально поддерживается одно соединение, для нескольких необходимы некоторые усложнения и мых их пока опустим.
Особенности:
Выводить информацию при соединении желательно на английском языке. Это позволяет избежать ситуации, когда на компьтере администратора не окажется поддержки русского языка и Telnet выведет ему абракадабру. У меня это наблюдается постоянно на английской NT 4 - приходится каждый раз лазить в настройки Telnet и задавать русский CharSet.
При соединении следует спросить пароль. Иначе каждый, кому нечего делать, залезет в программу и будет там ковыряться (из практики - преценденты были).
Переменная Connected отмечает, что пользователь еще не соединился с программой (т.е. не провел свою идентификацию). Рассмотрим сразу обработчик OnClientDisconnect, он еще проще:
// Поддержка связи по TCP/IP для удаленного конфигурирования - действия при отключении
procedure TMain.ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Connected := false;
Memo1.Lines.Add('Соединение разорвано');
end;
Итак, теперь настало время для самого интересного - написания обработчика OnClientRead. Этот обработчик вызывается всякий раз, когда от клиента приходят данные. Т.е. в свете приведенных выше теоретических замечаний это будет происходить при вводе каждого отдельного символа. Задачи обработчика:
Создавать (при необходимости) эхо для всех принимаемых символов. Очевидно, что при вводе паролей эхо создавать не нужно. При созании эха необходимо учитывать, что символ с кодом FF (буква "я") должен повторяться дважды, иначе он будет погложен Telnet - ом как служебный и не отобразится
Накапливать вводимые символы, ожидая прихода признака конца команы. Как правило, признаком конца команды считают перевод код строки (следует заметить, что тут разработчик сам себе стандарт, но отклоняться от общепринятых правил не рекомендуется. Для накопления принимаемой информации стоит завести буферную переменную, в моем случае она будет называться TelnetS.
При получении символа с кодом 08h ("BackSpace") необходимо не помещать ее в буфер, а стереть из буфера последний символ. Но в виде эха его отправить необходимо, т.к. это приведет к стиранию символа на экране Telnet (при подавлении эха он останется на экране, но сотрется в буфере программы, что приведет к путанице).
При обнаружении символа перевода строки (код $0D) следует считать содержимое буфера командой и интерпретировать. Как - это отдельный разговор
Все вышеописанное реализует примерно следующий код:
// Поддержка связи по TCP/IP для удаленного конфигурирования - действия при получении данных
procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
s, st: string;
begin
s := Socket.ReceiveText;
// Это код перевода строки ? Если да, то выполняем команду и передаем ее ответ клиенту
if ord(s[1]) = $0D then
begin
st := ExecuteCMD(TelnetS);
if st <> '' then
st := #$0D + #$0A + st;
st := st + #$0D + #$0A + '>';
TelnetSendText(Socket, st);
TelnetS := '';
exit;
end;
// Это код клавиши BackSpace. Если да, то передадим его клиенту
// и удалим последний символ из буфера
if ord(s[1]) = $08 then
begin
Delete(TelnetS, length(TelnetS), 1);
TelnetSendText(Socket, s);
exit;
end;
// Добавим очередной символ к буферу
TelnetS := TelnetS + s;
// Передадим его клиенту для организации эха
if connected then
TelnetSendText(Socket, s);
end;
Как легко заметить, приведенный выше код реализует эхо, обрабатывает BackSpace и дожидается ввода команды, считая код $OD (Enter) признаком завершения ввода команды. При обнаружении этого кода вызывается функция пользователя ExecuteCMD, которая должна разобрать и проанализировать команду, выполнить ее и вернуть (при необходомости) ответ пользователю. Эта же функция занимается проверкой вводимого пользователем пароля. Так ка передача ответа/эха имеет некоторые особенности, например, необходимость удвоения символа с кодом FF и подавления передачи для реализации невидимого ввода, имеет смысл выполнить ее в виде отдельной функции:
// Передача ответа/эха клиенту
function TForm1.TelnetSendText(Socket: TCustomWinSocket; AText: string): boolean;
var
i: integer;
St: string;
begin
Result := false;
if not(connected) then
exit;
St := '';
for i := 1 to length(AText) do
if AText[i] <> #$FF then
st := st + AText[i]
else
st := st + #$FF + #$FF;
Socket.SendText(st);
end;
// В моем примере функция ExecuteCMD имеет вид:
// Интерретатор команд
function TForm1.ExecuteCMD(ACmd: string): string;
var
UCmd, Params: string;
begin
Result := '';
Memo1.Lines.Add('Выполняется: '+ACmd);
if not(connected) then
begin
if UpperCase(ACmd) = '123' then
begin
Connected := true;
Result := 'Пользователь идентифицирован!';
end;
exit;
end;
// Выделение команды
UCmd := ACmd;
Params := '';
if pos(' ', UCmd) > 0 then
begin
Params := Copy(UCmd, pos(' ', UCmd)+1, Length(UCmd));
UCmd := Copy(UCmd, 1, pos(' ', UCmd)-1);
end;
UCmd := Trim(UpperCase(UCMD));
Memo1.Lines.Add('Выделена команда: '+UCmd);
// ? или HLP или HELP - вывод справки
if (UCmd = '?') or (UCmd = 'HLP') or (UCmd = 'HELP') then
begin
Result :=
'Краткая справка по командам Telnet интерфейса'+CRLF+
' ?, HLP, HELP - вызов справки'+CRLF+
' EXIT - завершение работы по Telnen интерфейсу'+CRLF+
' HALT - немедленный останов программы'+CRLF+
' VER - версия программы'+CRLF+
' MESS <собщение> - вывод сообщения для пользователя'+CRLF+
' INP <собщение> - вывод сообщения для пользователя и возврат его ответа';
exit;
end;
if (UCmd = 'EXIT') then
begin
ServerSocket1.Socket.Connections[0].Close;
exit;
end;
if (UCmd = 'VER') then
begin
Result := 'Версия 1.00 от 27.01.2001 (C) Зайцев Олег';
exit;
end;
if (UCmd = 'HALT') then
halt;
if (UCmd = 'MESS') then
begin
ShowMessage(Params);
exit;
end;
if (UCmd = 'INP') then
begin
Result := InputBox(Params,'Введите ответ', '');
exit;
end;
Result := 'Неизвестная команда ' + ACmd;
end;
Реальная система команд естественно определяется разработчиком, но рекомендуется предусмотреть следующие команды:
?, HLP, HELP для вывода справочной информации (практика показала, что при поддерке 20-30 команд больше половины забываются за месяц)
EXIT - завершение обмена
И, наконец, в завершении следует отметить одну особенность - пользователь может завершить обмен корректно (путем ввода команды EXIT (если таковая поддерживается) или выбором опции "Отключить" в Telnet; и некорректно - путем закрытия Telnet во время обмена. В этом случае в программе будет ошибка сокета 10054. Ее имеет смысл поймать и подавить при помощи обработчика OnClientError следующего вида:
procedure TForm1.ServerSocket1ClientError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
// Обработка события "разрыв соединения"
if ErrorCode = 10054 then
begin
Socket.Close;
ErrorCode := 0;
end;
end;
И в завершении хочется сказать, что подобная система внедрена в несколько моих программ, испрользуемых в ОАО Смоленскэнерго и отлично себя зарекомендовала, т.к. предприятие большое и возможность удаленной настройки/управления в ряде случаев освобождает разработчика от ненужной беготни.
Взято с
Управление транзакциями
Управление транзакциями
Each function listed below begins, ends, or inquires about the status of a transaction.
DbiBeginTran:
Begins a transaction.
DbiEndTran:
Ends a transaction.
DbiGetTranInfo:
Retrieves the transaction state.
Взято с
Delphi Knowledge BaseУправляющие коды принтера
Управляющие коды принтера
Как мне послать на принтер управляющие коды принтера(Printer Control Codes)без перевода их в непечатные символы? Наверняка без Windows API в Delphi не обойтись.Когда я передаю управляющие коды принтера, они печатаются как непечатные символы, а не воспринимаются принтером как управляющие коды.
Вам нужно использовать Escape функцию принтера Passthrough, чтобы переслать данные непосредственно в принтер.В случае использования функции WriteLn это, конечно, не работает.Вот некоторый код, чтобы уговорить вас начать:
unitPassthru;
interface
uses printers, WinProcs, WinTypes, SysUtils;
procedure PrintTest;
implementation
type
TPassThroughData = record
nLen: Integer;
Data: array[0..255] of byte;
end;
procedure DirectPrint(s: string);
var
PTBlock: TPassThroughData;
begin
PTBlock.nLen := Length(s);
StrPCopy(@PTBlock.Data, s);
Escape(printer.handle, PASSTHROUGH, 0, @PTBlock, nil);
end;
procedure PrintTest;
begin
Printer.BeginDoc;
DirectPrint(CHR(27) + '&l1O' + 'Привет, Вася!');
Printer.EndDoc;
end;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
After compiling and installing Apache
Using a DSO on Apache 2.0.43, created with Kylix 3
After compiling and installing Apache 2.0.39 with DSO support, deploying an .so file built with Kylix 3 doesn't work.
You need to change MODULE_MAGIC_NUMBER_MAJOR in HTTPD.pas file to the following: MODULE_MAGIC_NUMBER_MAJOR = 20020903;
Using Tapi
Using Tapi
How can I use TAPI to dial the telephone for a voice call?
The following example shows how to interface with tapi to make a
voice call.
{tapi Errors}
const TAPIERR_CONNECTED = 0;
const TAPIERR_DROPPED = -1;
const TAPIERR_NOREQUESTRECIPIENT = -2;
const TAPIERR_REQUESTQUEUEFULL = -3;
const TAPIERR_INVALDESTADDRESS = -4;
const TAPIERR_INVALWINDOWHANDLE = -5;
const TAPIERR_INVALDEVICECLASS = -6;
const TAPIERR_INVALDEVICEID = -7;
const TAPIERR_DEVICECLASSUNAVAIL = -8;
const TAPIERR_DEVICEIDUNAVAIL = -9;
const TAPIERR_DEVICEINUSE = -10;
const TAPIERR_DESTBUSY = -11;
const TAPIERR_DESTNOANSWER = -12;
const TAPIERR_DESTUNAVAIL = -13;
const TAPIERR_UNKNOWNWINHANDLE = -14;
const TAPIERR_UNKNOWNREQUESTID = -15;
const TAPIERR_REQUESTFAILED = -16;
const TAPIERR_REQUESTCANCELLED = -17;
const TAPIERR_INVALPOINTER = -18;
{tapi size constants}
const TAPIMAXDESTADDRESSSIZE = 80;
const TAPIMAXAPPNAMESIZE = 40;
const TAPIMAXCALLEDPARTYSIZE = 40;
const TAPIMAXCOMMENTSIZE = 80;
const TAPIMAXDEVICECLASSSIZE = 40;
const TAPIMAXDEVICEIDSIZE = 40;
function tapiRequestMakeCallA(DestAddress : PAnsiChar;
AppName : PAnsiChar;
CalledParty : PAnsiChar;
Comment : PAnsiChar) : LongInt;
stdcall; external 'TAPI32.DLL';
function tapiRequestMakeCallW(DestAddress : PWideChar;
AppName : PWideChar;
CalledParty : PWideChar;
Comment : PWideChar) : LongInt;
stdcall; external 'TAPI32.DLL';
function tapiRequestMakeCall(DestAddress : PChar;
AppName : PChar;
CalledParty : PChar;
Comment : PChar) : LongInt;
stdcall; external 'TAPI32.DLL';
procedure TForm1.Button1Click(Sender: TObject);
var
DestAddress : string;
CalledParty : string;
Comment : string;
begin
DestAddress := '1-555-555-1212';
CalledParty := 'Frank Borland';
Comment := 'Calling Frank';
tapiRequestMakeCall(pChar(DestAddress),
PChar(Application.Title),
pChar(CalledParty),
PChar(Comment));
end;
end.
Using the Shell API function SHBrowseForFolder
Using the Shell API function SHBrowseForFolder
uses ShellAPI, ShlObj;
procedure TForm1.Button1Click(Sender: TObject);
var
TitleName : string;
lpItemID : PItemIDList;
BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
begin
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
BrowseInfo.hwndOwner := Form1.Handle;
BrowseInfo.pszDisplayName := @DisplayName;
TitleName := 'Please specify a directory';
BrowseInfo.lpszTitle := PChar(TitleName);
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId nil then begin
SHGetPathFromIDList(lpItemID, TempPath);
ShowMessage(TempPath);
GlobalFreePtr(lpItemID);
end;
end;
Using Visual Basic arrays in Delphi
Using Visual Basic arrays in Delphi
How do I pass arrays from VB to Delphi?
Arrays can be passed as variants:
VB module code:
Attribute VB_Name = "Module1"
Declare Function TestMin Lib "c:\windows\system\NoelSArr"
(Nums As Variant) As Integer
VB form code:
Dim A As Variant
Private Sub Command1_Click()
A = Array(4, 3)
MsgBox (TestMin(A))
End Sub
Delphi DLL code:
library NoelSArray;
.
.
function TestMin(const Nums: Variant): integer; export; stdcall;
var
p1: Variant;
begin
p1 := VarArrayCreate([0, 1], VT_I4);
p1:= Nums;
if (p1[0] < p1[1]) then
result:= p1[0]
else
Result:= p1[1];
end;
Ускорение работы TreeView
Ускорение работы TreeView
Представляем вашему вниманию немного переработанный компонент TreeView, работающий быстрее своего собрата из стандартной поставки Delphi. Кроме того, была добавлена возможность вывода текста узлов и пунктов в жирном начертании (были использованы методы TreeView, хотя, по идее, необходимы были свойства TreeNode. Мне показалось, что это будет удобнее).
Для сравнения:
TreeView:
128 сек. для загрузки 1000 элементов (без сортировки)*
270 сек. для сохранения 1000 элементов (4.5 минуты!!!)
HETreeView:
1.5 сек. для загрузки 1000 элементов - ускорение около 850%!!! (2.3 секунды без сортировки = stText)*
0.7 сек. для сохранения 1000 элементов - ускорение около 3850%!!!
Примечание:
Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.
Если TreeView пуст, загрузка происходит за 1.5 секунды, плюс 1.5 секунды на стирание 1000 элементов (общее время загрузки составило 3 секунды). В этих условиях стандартный компонент TTreeView показал общее время 129.5 секунд. Очистка компонента осуществлялась вызовом функции SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).
Проведите несколько приятных минут, развлекаясь с компонентом.
unitHETreeView;
{$R-}
// Описание: Реактивный TreeView
(*
TREEVIEW:
128 сек. для загрузки 1000 элементов (без сортировки)*
270 сек. для сохранения 1000 элементов (4.5 минуты!!!)
HETREEVIEW:
1.5 сек. для загрузки 1000 элементов - ускорение около 850%!!!
(2.3 секунды без сортировки = stText)*
0.7 сек. для сохранения 1000 элементов - ускорение около 3850%!!!
NOTES:
- Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.
- * Если TTreeView пуст, загрузка происходит за 1.5 секунды,
плюс 1.5 секунды на стирание 1000 элементов
(общее время загрузки составило 3 секунды).
В этих условиях стандартный компонент TreeView показал общее время 129.5 секунд.
Очистка компонента осуществлялась вызовом функции
SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).
*)
interface
uses
SysUtils, Windows, Messages, Classes, Graphics,
Controls, Forms, Dialogs, ComCtrls, CommCtrl;
type
THETreeView = class(TTreeView)
private
FSortType: TSortType;
procedure SetSortType(Value: TSortType);
protected
function GetItemText(ANode: TTreeNode): string;
public
constructor Create(AOwner: TComponent); override;
function AlphaSort: Boolean;
function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
procedure LoadFromFile(const AFileName: string);
procedure SaveToFile(const AFileName: string);
procedure GetItemList(AList: TStrings);
procedure SetItemList(AList: TStrings);
//Жирное начертание шрифта 'Bold' должно быть свойством TTreeNode, но...
function IsItemBold(ANode: TTreeNode): Boolean;
procedure SetItemBold(ANode: TTreeNode; Value: Boolean);
published
property SortType: TSortType read FSortType write SetSortType default
stNone;
end;
procedure Register;
implementation
function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer;
stdcall;
begin
{with Node1 do
if Assigned(TreeView.OnCompare) then
TreeView.OnCompare(Node1.TreeView, Node1, Node2, lParam, Result)
else}
Result := lstrcmp(PChar(Node1.Text), PChar(Node2.Text));
end;
constructor THETreeView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSortType := stNone;
end;
procedure THETreeView.SetItemBold(ANode: TTreeNode; Value: Boolean);
var
Item: TTVItem;
Template: Integer;
begin
if ANode = nil then
Exit;
if Value then
Template := -1
else
Template := 0;
with Item do
begin
mask := TVIF_STATE;
hItem := ANode.ItemId;
stateMask := TVIS_BOLD;
state := stateMask and Template;
end;
TreeView_SetItem(Handle, Item);
end;
function THETreeView.IsItemBold(ANode: TTreeNode): Boolean;
var
Item: TTVItem;
begin
Result := False;
if ANode = nil then
Exit;
with Item do
begin
mask := TVIF_STATE;
hItem := ANode.ItemId;
if TreeView_GetItem(Handle, Item) then
Result := (state and TVIS_BOLD) <> 0;
end;
end;
procedure THETreeView.SetSortType(Value: TSortType);
begin
if SortType <> Value then
begin
FSortType := Value;
if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
(SortType in [stText, stBoth]) then
AlphaSort;
end;
end;
procedure THETreeView.LoadFromFile(const AFileName: string);
var
AList: TStringList;
begin
AList := TStringList.Create;
Items.BeginUpdate;
try
AList.LoadFromFile(AFileName);
SetItemList(AList);
finally
Items.EndUpdate;
AList.Free;
end;
end;
procedure THETreeView.SaveToFile(const AFileName: string);
var
AList: TStringList;
begin
AList := TStringList.Create;
try
GetItemList(AList);
AList.SaveToFile(AFileName);
finally
AList.Free;
end;
end;
procedure THETreeView.SetItemList(AList: TStrings);
var
ALevel, AOldLevel, i, Cnt: Integer;
S: string;
ANewStr: string;
AParentNode: TTreeNode;
TmpSort: TSortType;
function GetBufStart(Buffer: PChar; var ALevel: Integer): PChar;
begin
ALevel := 0;
while Buffer^ in [' ', #9] do
begin
Inc(Buffer);
Inc(ALevel);
end;
Result := Buffer;
end;
begin
// Удаление всех элементов - в обычной ситуации
// подошло бы Items.Clear, но уж очень медленно
SendMessage(handle, TVM_DELETEITEM, 0, Longint(TVI_ROOT));
AOldLevel := 0;
AParentNode := nil;
//Снятие флага сортировки
TmpSort := SortType;
SortType := stNone;
try
for Cnt := 0 to AList.Count - 1 do
begin
S := AList[Cnt];
if (Length(S) = 1) and (S[1] = Chr($1A)) then
Break;
ANewStr := GetBufStart(PChar(S), ALevel);
if (ALevel > AOldLevel) or (AParentNode = nil) then
begin
if ALevel - AOldLevel > 1 then
raise Exception.Create('Неверный уровень TreeNode');
end
else
begin
for i := AOldLevel downto ALevel do
begin
AParentNode := AParentNode.Parent;
if (AParentNode = nil) and (i - ALevel > 0) then
raise Exception.Create('Неверный уровень TreeNode');
end;
end;
AParentNode := Items.AddChild(AParentNode, ANewStr);
AOldLevel := ALevel;
end;
finally
//Возвращаем исходный флаг сортировки...
SortType := TmpSort;
end;
end;
procedure THETreeView.GetItemList(AList: TStrings);
var
i, Cnt: integer;
ANode: TTreeNode;
begin
AList.Clear;
Cnt := Items.Count - 1;
ANode := Items.GetFirstNode;
for i := 0 to Cnt do
begin
AList.Add(GetItemText(ANode));
ANode := ANode.GetNext;
end;
end;
function THETreeView.GetItemText(ANode: TTreeNode): string;
begin
Result := StringOfChar(' ', ANode.Level) + ANode.Text;
end;
function THETreeView.AlphaSort: Boolean;
var
I: Integer;
begin
if HandleAllocated then
begin
Result := CustomSort(nil, 0);
end
else
Result := False;
end;
function THETreeView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
var
SortCB: TTVSortCB;
I: Integer;
Node: TTreeNode;
begin
Result := False;
if HandleAllocated then
begin
with SortCB do
begin
if not Assigned(SortProc) then
lpfnCompare := @DefaultTreeViewSort
else
lpfnCompare := SortProc;
hParent := TVI_ROOT;
lParam := Data;
Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
end;
if Items.Count > 0 then
begin
Node := Items.GetFirstNode;
while Node <> nil do
begin
if Node.HasChildren then
Node.CustomSort(SortProc, Data);
Node := Node.GetNext;
end;
end;
end;
end;
//Регистрация компонента
procedure Register;
begin
RegisterComponents('Win95', [THETreeView]);
end;
end.
Взято с
Установка BDE
Установка BDE
Cодержание раздела:
Установка Interbase и добавление пользователя
Установка Interbase и добавление пользователя
Автор: Denis Alexandrovich Ivanov
Как сделать инсталятор, который прописывал бы пользователя в Interbase? BDE при этом не нужна совсем.
1. При помощи InstallShieldExpress формируется проект, который включает в себя установку Interbase Server.
2. После установки Interbase запускаешь программу, написанную на Delphi 6, которая добавляет нового пользователя Interbase
{************************************************************************
Проект: ....
Автор : Иванов Д.А.
Назначение : Выжимки из библиотеки функций для работы со справочником
пользователей
Note: You must install InterBase 6 to use this feature.
Дата создания: 11.13.2002
История :
************************************************************************}
unit usr;
interface
uses IBCustomDataSet,IBDataBase,IBServices;
type
TUsrInfo = record
Usr:string ; //login
Uid:integer; //уникальный идентификатор, если программа ведет
//справочник пользователей в своей БД - его можно
//брать оттуда по секвенции
Grp:integer; //Group
Pas:string ; //password
end;
TUsrClass = class(TObject)
private
{ Private declarations }
public
UsrData:TUsrInfo;
dbSec :TIBSecurityService;
// добавляет или редактирует пользователя в Interbase
function UpdateUser: string;
end;
TUsrLib = class(TUsrClass)
private
{ Private declarations }
public
procedure AddNewUserToInterbase;
end;
var
clUsr:TUsrLib;
implementation
uses SysUtils,Controls,db,windows,QDialogs;
(***************** Добавляет или редактирует пользователя ***************)
function TUsrClass.UpdateUser: string;
//Usrid = 0 - новый пользователь
var Edes:string; //Описание ошибок
begin
try
if UsrData.Usr = '' then Edes:= 'не указан login пользователя';
if UsrData.Uid = 0 then Edes:= 'не указан id пользователя';
if UsrData.Grp = 0 then Edes:= 'не
if UsrData.Pas = '' then Edes:= 'не указан пароль пользователя';
if EDes < > '' then raise Exception.Create(Edes);
//Добавляем пользователя в interbase
with dbSec do begin
if not Active then Active := True;
UserName := UsrData.Usr;
UserID := UsrData.Uid;
GroupID := UsrData.Grp;
Password := UsrData.Pas;
try
DisplayUser(UserName);
if UserInfo[0] = nil then AddUser else ModifyUser;
except
Edes:='Ошибка добавления пользователя в interbase security';
raise Exception.Create(Edes);
end;
//раздача если нужно права доступа пользователя на таблицы
(* EDes:= GrantData(UsrData.Usr);
if EDes < > '' then raise Exception.Create(Edes);
*)
end;
except
if EDes = '' then EDes:= 'Ошибка добавления пользователя в interbase security';
end;
Result:= EDes;
end;
procedure TUsrLib.AddNewUserToInterbase;
var Edes:string; //Описание ошибок
begin
UsrData.Usr := 'ida' ;
UsrData.Uid := 123 ;
UsrData.Grp := 1 ;
UsrData.Pas := 'pass';
EDes:= UpdateUser;
if EDes < > '' then raise Exception.Create(Edes);
end;
begin
clUsr:=TUsrLib.Create;
end.
Установку Interbase 6.0 я пробовал делать двумя системами создания инсталляций:
- InstallShield
- Wise Install Builder.
Для обоих использовал готовые скрипты с сайта http://ibinstall.defined.net/. По результатам могу сказать, что Wise удобнее и проще в инсталляции. Кроме того у него есть текстовый редактор скрипта, что нашему брату шибко нравится. Установка и запуск IBGuard проходит как и в фирменном варианте сразу (Silent Install).
Взято из
Установка каретки в RichEdit
Установка каретки в RichEdit
Узнать положение курсора в RichEdit не составляет труда (richedit.getcaret). А вот как установить каретку в нужное место ?.
Procedure setline(WhichEdit:TRichedit;Linepos,charpos:integer);
Begin
with WhichEdit do
begin
selstart:=perform(EM_LineIndex,Linenum,0)+charpos;
perform(EM_ScrollCaret,0,0);
end;
end;
Комментарии:
Если Вам не нужно, чтобы происходил скроллинг к позиции каретки, то EM_ScrollCaret можно убрать. Эта процедура так же может быть использована для TMemo, только надо будет заменить объявление witchedit на TMemo:
Procedure CustomMemoSetline(WhichEdit:TCustomMemo;Linepos,charpos:integer);
Так же эту процедуру можно использовать как ответ на вопрос "Как установить фокус на определённую строку в компоненте Memo ?". Для этого необходимо добавить следующий код после строки selstart:
sellength:=length(lines(line));
И установить charpos в 0.
RichEdit должен иметь фокус, иначе em_ScrollCaret не сработает.
Взято с Исходников.ru
Установка ODBC
Установка ODBC
Автор: Johannes M. Becher (CODATA GmbH Krefeld, Germany)
...если вам нужно знать, что творится за сценой, нужно просто взглянуть на эти два файла, оба человеко-читаемых, оба расположенных в вашей директории Windows.
A) ODBCINST.INI - описание всех установленных драйверов ODBC
Секция [ODBC Drivers] в каждой строчке описывает один драйвер. Здесь прописано формальное имя драйвера, использующегося позже для идентификации драйвера.
Каждый драйвер, как вы увидите позже, имеет собственную секцию, к примеру, вот секция для Watcom :
{1} [Watcom SQL 4.0]
{2} Driver=D:\WIN31\SYSTEM\WOD40W.DLL
{3} Setup=D:\WIN31\SYSTEM\WOD40W.DLL
Строка 1 содержит имя секции драйвера из [ODBC Drivers].
Строка 2 сообщает Windows о том, где следует искать DLL, содержащую методы, применяемые ODBC для доступа к базам данных Watcom.
Строка 3 сообщает Windows о том, где следует искать DLL, содержащую методы, применяемые ODBC для административных целей.
Все, что имеется в файле ODBCINST.INI - теперь содержится в файле #2 (таком же легком для изучения):
B) ODBC.INI - описание всех ваших баз данных (источников данных, говоря языком ODBC)
Секция [ODBC Data Sources] в каждой строчке описывает одну базу данных; формат:
{описание базы данных} = {описание драйвера из ODBCINST.INI}
Данный файл сообщает ODBC, к каким базам данных вы хотите иметь доступ и какой драйвер для каждой конкретной базы данных для этого необходим.
Каждая база данных, как вы увидите позже, имеет собственную секцию, к примеру, вот секция PB Demo:
{1} [Powersoft Demo DB=Watcom SQL 4.0]
{2} DatabaseFile=E:\PB4\EXAMPLES\PSDEMO.DB
{3} DatabaseName=PSDEMODB
{4} UID=dba
{5} PWD=sql
{6} Driver=D:\WIN31\SYSTEM\WOD40W.DLL
{7} Start=D:\WSQL40\DBSTARTW -d -c512
Строка 1 содержит ссылку на секцию [ODBC Data Sources].
Строка 2 содержит физический путь к файлу базы данных.
Строка 3 - описание, только для вашего чтения.
Строка 4 - User ID, которое Watcom применяет для установления связи.
Строка 5 - Пароль, используемый для установления соединения.
- Это не очень секретно; если вы оставите эту строку пустой, Watcom сам спросит пароль при получении доступа к базе данных.
Строка 6 содержит имя драйвера (снова - сравните с OBDCINST.INI)
Строка 7 содержит имя движка базы данных для ее запуска (это необходимо лишь для баз данных SQL, например, в версии Client / Server).
Все это может быть отредактировано как вручную (в любом текстовом редакторе), так и в ODBCADM (ODBC Administration). Что касается меня лично, то я более не использую ODBCADM; я ощущаю себя гораздо лучше, если имею больший контроль над INI-файлами, редактируя строки вручную.
Структура секций в файле ODBC.INI может отличаться для разных драйверов, поэтому вам необходимо научиться ориентироваться по ключевым словам, описанным выше.
Предупреждение: весь опубликованный мною материал получен путем моих собственных исследований, вследствие чего я не могу гарантировать его достоверность. По крайней мере я успешно использую его для получения доступа к ODBC уже более года.
Взято с
UUE кодирование
UUE кодирование
Автор: Sergei Dubarev
Для того, чтобы ОНО заработало, необходимо создать проект в составе:
Форма (form) - 1 шт.
Поле ввода (edit) - 2 шт., используются события OnDblClick.
Кнопка (button) - 1 шт., используется событие OnClick.
Диалог открытия файла (Open Dialog) - 1 шт.
Диалог сохранения файла (Save Dialog) - 1 шт.
Имена файлов будут вводится либо вручную, либо из диалога (double-click на поле ввода edit), причем в edit1.text должно лежать имя входного файла, в edit2.text - выходного. По нажатии кнопки пойдет процесс, который завершится сообщением "DONE."
Всего хорошего.
P. S. Функция toanysys обнаружена в книге "Для чего нужны и как работают персональные ЭВМ" от 1990 г. Там она присутствует в виде программы на BASIC'e.
P.P.S. Для стимулирования фантазии читателей "Советов..." высылаю так же мессагу из эхи, на основе которой я сваял свое чудо.
Файл Unit1.pas
//UUEкодирование
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtDlgs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
procedure Edit1DblClick(Sender: TObject);
procedure Edit2DblClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
ssz = (High(Cardinal) - $F) div sizeof(byte);
//эта константа используется при выделении памяти
p: string = '0123456789ABCDEF';
//эта константа используется функцией toanysys
//выбор входного файла
procedure TForm1.Edit1DblClick(Sender: TObject);
begin
if opendialog1.execute then
edit1.text := opendialog1.filename;
end;
//выбор выходного (UUE) файла
procedure TForm1.Edit2DblClick(Sender: TObject);
begin
if savedialog1.execute then
edit2.text := savedialog1.filename;
end;
//выделение подстроки
function mid(s: string; fromc, toc: byte): string;
var
s1: string;
i: byte;
begin
s1 := '';
for i := fromc to toc do
s1 := s1 + s[i];
mid := s1;
end;
//перевод числа (a) из десятичной системы в другую
//с основанием (r)
function toanysys(a, r: byte): string;
var
s,
k: string;
n,
m,
i: byte;
begin
s := '';
m := 1;
while m <> 0 do
begin
m := a div r;
n := a - m * r + 1;
k := p[n];
s := k + s;
a := m;
end;
//добавляет незначащие нули
for i := 1 to 8 - length(s) do
s := '0' + s;
toanysys := s;
end;
//перевод 6-разрядного числа из двоичной системы в десятичную
//двоичное число подставляется в виде строки символов
function frombin(s: string): byte;
var
i,
e,
b: byte;
begin
b := 0;
for i := 1 to 6 do
begin
e := 1 shl (6 - i);
if s[i] = '1' then
b := b + e;
end;
frombin := b;
end;
//непосредственно кодирование
type
tcoola = array[1..1] of byte;
pcoola = ^tcoola;
procedure TForm1.Button1Click(Sender: TObject);
var
inf: file of byte;
ouf: textfile;
uue: pcoola;
b: array[1..4] of byte;
bin,
t: string;
szf,
oum,
szl,
szh,
sxl,
sxh,
i,
j: longint;
begin
{$I-}
assignfile(inf, edit1.text); //входной файл
reset(inf);
szf := filesize(inf); //
szh := (szf * 8) div 6; //
if szf * 8 - szh * 6 = 0 then
szl := 0
else
szl := 1; //
getmem(uue, szh + szl); //выделение памяти
oum := 1;
while not (eof(inf)) do
begin
b[1] := 0;
b[2] := 0;
b[3] := 0;
b[4] := 0;
//чтение должно быть сделано посложнее,
//дабы избежать "read beyond end of file"
read(inf, b[1], b[2], b[3]);
//читаем 3 байта из входного файла
//и формируем "двоичную" строку
bin := toanysys(b[1], 2) +
toanysys(b[2], 2) +
toanysys(b[3], 2);
//разбиваем строку на куски по 6 бит и добавляем 32
t := mid(bin, 19, 24);
b[4] := frombin(t) + 32;
t := mid(bin, 13, 18);
b[3] := frombin(t) + 32;
t := mid(bin, 07, 12);
b[2] := frombin(t) + 32;
t := mid(bin, 01, 06);
b[1] := frombin(t) + 32;
//запихиваем полученнные байты во временный массив
uue[oum] := b[1];
oum := oum + 1;
uue[oum] := b[2];
oum := oum + 1;
uue[oum] := b[3];
oum := oum + 1;
uue[oum] := b[4];
oum := oum + 1;
end;
//входной файл больше не нужен - закрываем его
closefile(inf);
//формируем выходной файл
assignfile(ouf, edit2.text); //выходной файл
rewrite(ouf);
oum := 1;
sxh := (szh + szl) div 60; //число строк в UUE файле
sxl := (szh + szl) - sxh * 60;
//заголовок UUE-файла
writeln(ouf, 'begin 644 ' + extractfilename(edit1.text));
//записываем строки в файл
for i := 1 to sxh do
begin
write(ouf, 'M');
// 'M' значит, что в строке 60 символов
for j := 1 to 60 do
begin
write(ouf, chr(uue[oum]));
oum := oum + 1;
end;
writeln(ouf);
end;
//записываем последнюю строку, которая
//обычно короче 60 символов
sxh := (sxl * 6) div 8;
write(ouf, chr(sxh + 32));
for i := 1 to sxl do
begin
write(ouf, chr(uue[oum]));
oum := oum + 1;
end;
// "добиваем" строку незначащими символами
for i := sxl + 1 to 60 do
write(ouf, '`');
//записываем последние строки файла
writeln(ouf);
writeln(ouf, '`');
writeln(ouf, 'end');
closefile(ouf);
freemem(uue, szh + szl); //освобождаем память
showmessage('DONE.'); //Готово. Забирайте!
end;
end.
1) Читаем из исходного хфайла 3 байта.
2) Разбиваем полyченные 24 бита (8x3=24) на 4 части, т.е. по 6 бит.
3) Добавляем к каждой части число 32 (десятичн.)
Пpимеp: Имеем тpи числа 234 12 76. Побитово бyдет так -
11101010 00001100 01001100 pазбиваем и полyчаем -
111010 100000 110001 001100 добавляем 32 -
+100000 +100000 +100000 +100000
------ ------ ------ ------
1011010 1000000 1010001 101100 или в бyквах -
Z @ Q ,
Вот собственно и все. В UUE файле в пеpвой позиции стоит кол-во закодиpованных
символов + 32. Т.е. вся стpока содеpжит 61 символ. 1 символ идет на кол-во.
Остается 60 символов _кода_. Если подсчитать, то мы yвидим, что для полyчения
60
символов кода необходимо 45 исходных символов. Для полной стpоки в начале стоит
бyква "M", а ее ASCII код = 77. 45+32=77.
Взято с
В чем отличие между Create(Self) и Create(Application)?
В чем отличие между Create(Self) и Create(Application)?
Self может быть использовано только в методе класса, и ссылается на текущий экземпляр класса. Таким образом "Self" в методе класса TForm1 ссылается на текущий экземпляр TForm1. При создании компонента Вы передаете его владельца (owner) в конструктор. При уничтожении формы или компонента автоматически уничтожаются и все компоненты владельцем которого она является. Таким образом если при создании формы передать в качестве владельца Application эта форма будет автоматически уничтожена при уничтожении Application. Если же при создании формы передать в качестве владельца другую форму, вновь созданная форма будет автоматически уничтоженна при уничтожении формы-владельца.
В чем разница между CHAR и VARCHAR ? Что лучше использовать?
В чем разница между CHAR и VARCHAR ? Что лучше использовать?
Разработчики утверждают, что разницы практически нет - особенности VARCHAR в том, что используется дополнительно два байта для хранения длины, а CHAR игнорирует пробелы в конце хранимой строки.
Если вы собираетесь хранить строки длиной не более 40-50 символов, то лучше использовать CHAR. Более подробно см. статью.
При передаче по сети в текущих версиях IB VARCHAR передается так-же как и CHAR (т.е. неэффективно). Исправлено в IB 5.0.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко
В InterBase при создании базы ввести параметр для поддержки русского языка
В InterBase при создании базы ввести параметр для поддержки русского языка
UPDATERDB$FIELDS
SET RDB$CHARACTER_SET_ID = 52
WHERE RDB$FIELD_NAME = 'RDB$SOURCE''
Взято из
В каком порядке происходят события при создании и показе окна?
В каком порядке происходят события при создании и показе окна?
При создании окна обработчики событий выполняются в следующем порядке:
OnCreate
OnShow
OnPaint
OnActivate
OnResize
OnPaint (снова)
Copyright © 1996 Epsylon Technologies
Взято из
FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349В основном Help'е в Delphi не работает индекс по Win32?
В основном Help'е в Delphi не работает индекс по Win32?
- в /help/delphi3.cfg добавить строку типа
:index Win32=Win32.hlp
она должна быть добавлена перед строкой
:Link win32.hlp
- стереть delphi3.gid
- запустить Help и получать удовольствие
В delphi3.cnt тоже нужно строчку добавить:
:include win32.cnt
Взято с сайта
VCL
VCL
Cодержание раздела:
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
· (раздел)
· (раздел)
· (раздел)
· (раздел)
· (раздел)
· (раздел)
· (раздел)
· (раздел)
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
См. также другие разделы:
См. также статьи в других разделах:
Вертикальный текст
Вертикальный текст
var
Hfont: Thandle;
logfont: TLogFont;
font: Thandle;
count: integer;
begin
LogFont.lfheight := 30;
logfont.lfwidth := 10;
logfont.lfweight := 900;
LogFont.lfEscapement := -200;
logfont.lfcharset := 1;
logfont.lfoutprecision := out_tt_precis;
logfont.lfquality := draft_quality;
logfont.lfpitchandfamily := FF_Modern;
font := createfontindirect(logfont);
Selectobject(Form1.canvas.handle, font);
SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
SetBKmode(Form1.canvas.handle, transparent);
{textout(form1.canvas.handle,10,10,'Повернутый',7);}
for count := 1 to 100 do
begin
canvas.textout(Random(form1.width), Random(form1.height), 'Повернутый');
SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255),
Random(255)));
end;
deleteobject(font);
end;
Взято из
Видоизменяем чекбоксы в Delphi
Видоизменяем чекбоксы в Delphi
В WIN3.1 чекбоксы заполняются символом "X". В WIN95 и WINNT - символом "V". В тандартной палитре Delphi чекбоксы заполняются символом "X". Спрашивается - почему фирма Borland/Inprise не исправила значёк чекбокса для W95/W98 ?. Данный пример позволяет заполнять чекбокс такими значками как: "X", "V", "o", "закрашенным прямоугольником", или бриллиантиком.
Пример тестировался под WIN95 и WINNT.
{
====================================================================
Обозначения
====================================================================
X = крестик
V = галочка
o = кружок
+-+
|W| = заполненный прямоугольник
+-+
/\
= бриллиантик
\/
====================================================================
Преимущества этого чекбокса
====================================================================
Вы можете найти множество чекбоксов в интернете. Но у них есть недостаток, они не обрабатывают сообщение WM_KILLFOCUS. Приведённый ниже пример делает это.
====================================================================
}
Unit CheckBoxX;
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
Const
{ другие константы }
fRBoxWidth : Integer = 13; // ширина квадрата checkbox
fRBoxHeight : Integer = 13; // высота квадрата checkbox
Type
TState = (cbUnchecked,cbChecked,cbGrayed); // такой же как в Delphi
TType = (cbCross,cbMark,cbBullet,cbDiamond,cbRect); // добавленный
TMouseState = (msMouseUp,msMouseDown);
TAlignment = (taRightJustify,taLeftJustify); // The same
TCheckBoxX = class(TCustomControl)
Private
{ Private declarations }
fChecked : Boolean;
fCaption : String;
fColor : TColor;
fState : TState;
fFont : TFont;
fAllowGrayed : Boolean;
fFocus : Boolean;
fType : TType;
fMouseState : TMouseState;
fAlignment : TAlignment;
fTextTop : Integer; // отступ текта с верху
fTextLeft : Integer; // отступ текта с лева
fBoxTop : Integer; // координата чекбокса сверху
fBoxLeft : Integer; // координата чекбокса слева
Procedure fSetChecked(Bo : Boolean);
Procedure fSetCaption(S : String);
Procedure fSetColor(C : TColor);
Procedure fSetState(cbState : TState);
Procedure fSetFont(cbFont : TFont);
Procedure fSetAllowGrayed(Bo : Boolean);
Procedure fSetType(T : TType);
Procedure fSetAlignment(A : TAlignment);
Protected
{ Protected declarations }
Procedure Paint; override;
Procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
Procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
Procedure WMKillFocus(var Message : TWMKillFocus);
Message WM_KILLFOCUS; // это убирает контур фокуса!
Procedure WMSetFocus(var Message : TWMSetFocus);
Message WM_SETFOCUS; // Если вы используете клавишу TAB или Shift-Tab
Procedure KeyDown(var Key : Word; Shift : TShiftState); override;
// перехват KeyDown
Procedure KeyUp(var Key : Word; Shift : TShiftState); override;
// перехват KeyUp
Public
{ Public declarations }
// Если поместить Create и Destroy в раздел protected,
// то Delphi начинает ругаться.
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Published
{ Published declarations }
{ --- Свойства --- }
Property Action;
Property Alignment : TAlignment
read fAlignment write fSetAlignment;
Property AllowGrayed : Boolean
read fAllowGrayed write fSetAllowGrayed;
Property Anchors;
Property BiDiMode;
Property Caption : String
read fCaption write fSetCaption;
Property CheckBoxType : TType
read fType write fSetType;
Property Checked : Boolean
read fChecked write fSetChecked;
Property Color : TColor
read fColor write fSetColor;
Property Constraints;
//Property Ctrl3D;
Property Cursor;
Property DragCursor;
Property DragKind;
Property DragMode;
Property Enabled;
Property Font : TFont
read fFont write fSetFont;
//Property Height;
Property HelpContext;
Property Hint;
Property Left;
Property Name;
//Property PartenBiDiMode;
Property ParentColor;
//Property ParentCtrl3D;
Property ParentFont;
Property ParentShowHint;
//Property PopMenu;
Property ShowHint;
Property State : TState
read fState write fSetState;
Property TabOrder;
Property TabStop;
Property Tag;
Property Top;
Property Visible;
//Property Width;
{ --- Events --- }
Property OnClick;
Property OnContextPopup;
Property OnDragDrop;
Property OnDragOver;
Property OnEndDock;
Property OnEndDrag;
Property OnEnter;
Property OnExit;
Property OnKeyDown;
Property OnKeyPress;
Property OnKeyUp;
Property OnMouseDown;
Property OnMouseMove;
Property OnMouseUp;
Property OnStartDock;
Property OnStartDrag;
End;
Procedure Register; //Hello!
Implementation
{-------------------------------------------------------------------}
Procedure TCheckBoxX.KeyDown(var Key : Word; Shift : TShiftState);
Begin
If fFocus then
If Shift = [] then
If Key = 0032 then
Begin
fMouseState := msMouseDown;
If fState <> cbGrayed then
Begin
SetFocus; // Устанавливаем фокус на этот компонент
// всем другим компонентам Windows посылает сообщение WM_KILLFOCUS.
fFocus := True;
Invalidate;
End;
End;
Inherited KeyDown(Key,Shift);
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.KeyUp(var Key : Word; Shift : TShiftState);
Begin
If fFocus then
If Shift = [] then
If Key = 0032 then
Begin
If fState <> cbGrayed then
fSetChecked(not fChecked); // Изменяем состояние
fMouseState := msMouseUp;
End;
Inherited KeyUp(Key,Shift);
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.WMSetFocus(var Message : TWMSetFocus);
Begin
fFocus := True;
Invalidate;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.WMKillFocus(var Message : TWMKillFocus);
Begin
fFocus := False; // Удаляем фокус у всех компонент, которые не имеют фокуса.
Invalidate;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetAlignment(A : TAlignment);
Begin
If A <> fAlignment then
Begin
fAlignment := A;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetType(T : TType);
Begin
If fType <> T then
Begin
fType := T;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetFont(cbFont : TFont);
Var
FontChanged : Boolean;
Begin
FontChanged := False;
If fFont.Style <> cbFont.Style then
Begin
fFont.Style := cbFont.Style;
FontChanged := True;
End;
If fFont.CharSet <> cbFont.Charset then
Begin
fFont.Charset := cbFont.Charset;
FontChanged := True;
End;
If fFont.Size <> cbFont.Size then
Begin
fFont.Size := cbFont.Size;
FontChanged := True;
End;
If fFont.Name <> cbFont.Name then
Begin
fFont.Name := cbFont.Name;
FontChanged := True;
End;
If fFont.Color <> cbFont.Color then
Begin
fFont.Color := cbFont.Color;
FontChanged := True;
End;
If FontChanged then
Invalidate;
End;
{-------------------------------------------------------------------}
procedure TCheckBoxX.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
Begin
// Процедура MouseDown вызывается, когда кнопка мышки нажимается в пределах
// кнопки, соответственно мы не можем получить значения координат X и Y.
inherited MouseDown(Button, Shift, X, Y);
fMouseState := msMouseDown;
If fState <> cbGrayed then
Begin
SetFocus; // Устанавливаем фокус на этот компонент
// всем другим компонентам Windows посылает сообщение WM_KILLFOCUS.
fFocus := True;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
procedure TCheckBoxX.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
Begin
// Процедура MouseUp вызывается, когда кнопка мышки отпускается в пределах
// кнопки, соответственно мы не можем получить значения координат X и Y.
inherited MouseUp(Button, Shift, X, Y);
If fState <> cbGrayed then
fSetChecked(not fChecked); // Изменяем состояние
fMouseState := msMouseUp;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetAllowGrayed(Bo : Boolean);
Begin
If fAllowGrayed <> Bo then
Begin
fAllowGrayed := Bo;
If not fAllowGrayed then
If fState = cbGrayed then
Begin
If fChecked then
fState := cbChecked
else
fState := cbUnChecked;
End;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetState(cbState : TState);
Begin
If fState <> cbState then
Begin
fState := cbState;
If (fState = cbChecked) then
fChecked := True;
If (fState = cbGrayed) then
fAllowGrayed := True;
If fState = cbUnChecked then
fChecked := False;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetColor(C : TColor);
Begin
If fColor <> C then
Begin
fColor := C;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetCaption(S : String);
Begin
If fCaption <> S then
Begin
fCaption := S;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetChecked(Bo : Boolean);
Begin
If fChecked <> Bo then
Begin
fChecked := Bo;
If fState <> cbGrayed then
Begin
If fChecked then
fState := cbChecked
else
fState := cbUnChecked;
End;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
procedure TCheckBoxX.Paint;
var
Buffer: array[0..127] of Char;
I: Integer;
fTextWidth, fTextHeight: Integer;
begin
{Get Delphi's componentname and initially write it in the caption}
GetTextBuf(Buffer, SizeOf(Buffer));
if Buffer <> '' then
fCaption := Buffer;
Canvas.Font.Size := Font.Size;
Canvas.Font.Style := Font.Style;
Canvas.Font.Color := Font.Color;
Canvas.Font.Charset := Font.CharSet;
fTextWidth := Canvas.TextWidth(fCaption);
fTextHeight := Canvas.TextHeight('Q');
if fAlignment = taRightJustify then
begin
fBoxTop := (Height - fRBoxHeight) div 2;
fBoxLeft := 0;
fTextTop := (Height - fTextHeight) div 2;
fTextLeft := fBoxLeft + fRBoxWidth + 4;
end
else
begin
fBoxTop := (Height - fRBoxHeight) div 2;
fBoxLeft := Width - fRBoxWidth;
fTextTop := (Height - fTextHeight) div 2;
fTextLeft := 1;
//If fTextWidth > (Width - fBoxWidth - 4) then
// fTextLeft := (Width - fBoxWidth - 4) - fTextWidth;
end;
// выводим текст в caption
Canvas.Pen.Color := fFont.Color;
Canvas.Brush.Color := fColor;
Canvas.TextOut(fTextLeft, fTextTop, fCaption);
// Рисуем контур фокуса
if fFocus = True then
Canvas.DrawFocusRect(Rect(fTextLeft - 1,
fTextTop - 2,
fTextLeft + fTextWidth + 1,
fTextTop + fTextHeight + 2));
if (fState = cbChecked) then
Canvas.Brush.Color := clWindow;
if (fState = cbUnChecked) then
Canvas.Brush.Color := clWindow;
if (fState = cbGrayed) then
begin
fAllowGrayed := True;
Canvas.Brush.Color := clBtnFace;
end;
// Создаём бокс clBtnFace когда кнопка мыши нажимается
// наподобие "стандартного" CheckBox
if fMouseState = msMouseDown then
Canvas.Brush.Color := clBtnFace;
Canvas.FillRect(Rect(fBoxLeft + 2,
fBoxTop + 2,
fBoxLeft + fRBoxWidth - 2,
fBoxTop + fRBoxHeight - 2));
// Рисуем прямоугольный чекбокс
Canvas.Brush.Color := clBtnFace;
Canvas.Pen.Color := clGray;
Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1, fBoxTop);
Canvas.LineTo(fBoxLeft, fBoxTop);
Canvas.LineTo(fBoxLeft, fBoxTop + fRBoxHeight);
Canvas.Pen.Color := clWhite;
Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1, fBoxTop);
Canvas.LineTo(fBoxLeft + fRBoxWidth - 1,
fBoxTop + fRBoxHeight - 1);
Canvas.LineTo(fBoxLeft - 1, fBoxTop + fRBoxHeight - 1);
Canvas.Pen.Color := clBlack;
Canvas.MoveTo(fBoxLeft + fRBoxWidth - 3, fBoxTop + 1);
Canvas.LineTo(fBoxLeft + 1, fBoxTop + 1);
Canvas.LineTo(fBoxLeft + 1, fBoxTop + fRBoxHeight - 2);
Canvas.Pen.Color := clBtnFace;
Canvas.MoveTo(fBoxLeft + fRBoxWidth - 2, fBoxTop + 1);
Canvas.LineTo(fBoxLeft + fRBoxWidth - 2,
fBoxTop + fRBoxHeight - 2);
Canvas.LineTo(fBoxLeft, fBoxTop + fRBoxHeight - 2);
// Теперь он должен быть таким же как чекбокс в Delphi
if fChecked then
begin
Canvas.Pen.Color := clBlack;
Canvas.Brush.Color := clBlack;
// Рисуем прямоугольник
if fType = cbRect then
begin
Canvas.FillRect(Rect(fBoxLeft + 4, fBoxTop + 4,
fBoxLeft + fRBoxWidth - 4, fBoxTop + fRBoxHeight - 4));
end;
// Рисуем значёк "о"
if fType = cbBullet then
begin
Canvas.Ellipse(fBoxLeft + 4, fBoxTop + 4,
fBoxLeft + fRBoxWidth - 4, fBoxTop + fRBoxHeight - 4);
end;
// Рисуем крестик
if fType = cbCross then
begin
{Right-top to left-bottom}
Canvas.MoveTo(fBoxLeft + fRBoxWidth - 5, fBoxTop + 3);
Canvas.LineTo(fBoxLeft + 2, fBoxTop + fRBoxHeight - 4);
Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4, fBoxTop + 3);
Canvas.LineTo(fBoxLeft + 2, fBoxTop + fRBoxHeight - 3);
Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4, fBoxTop + 4);
Canvas.LineTo(fBoxLeft + 3, fBoxTop + fRBoxHeight - 3);
{Left-top to right-bottom}
Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 4);
Canvas.LineTo(fBoxLeft + fRBoxWidth - 4,
fBoxTop + fRBoxHeight - 3);
Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 3);
Canvas.LineTo(fBoxLeft + fRBoxWidth - 3,
fBoxTop + fRBoxHeight - 3); //mid
Canvas.MoveTo(fBoxLeft + 4, fBoxTop + 3);
Canvas.LineTo(fBoxLeft + fRBoxWidth - 3,
fBoxTop + fRBoxHeight - 4);
end;
// Рисуем галочку
if fType = cbMark then
for I := 0 to 2 do
begin
{Left-mid to left-bottom}
Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 5 + I);
Canvas.LineTo(fBoxLeft + 6, fBoxTop + 8 + I);
{Left-bottom to right-top}
Canvas.MoveTo(fBoxLeft + 6, fBoxTop + 6 + I);
Canvas.LineTo(fBoxLeft + 10, fBoxTop + 2 + I);
end;
// Рисуем бриллиантик
if fType = cbDiamond then
begin
Canvas.Pixels[fBoxLeft + 06, fBoxTop + 03] := clBlack;
Canvas.Pixels[fBoxLeft + 06, fBoxTop + 09] := clBlack;
Canvas.MoveTo(fBoxLeft + 05, fBoxTop + 04);
Canvas.LineTo(fBoxLeft + 08, fBoxTop + 04);
Canvas.MoveTo(fBoxLeft + 05, fBoxTop + 08);
Canvas.LineTo(fBoxLeft + 08, fBoxTop + 08);
Canvas.MoveTo(fBoxLeft + 04, fBoxTop + 05);
Canvas.LineTo(fBoxLeft + 09, fBoxTop + 05);
Canvas.MoveTo(fBoxLeft + 04, fBoxTop + 07);
Canvas.LineTo(fBoxLeft + 09, fBoxTop + 07);
Canvas.MoveTo(fBoxLeft + 03, fBoxTop + 06);
Canvas.LineTo(fBoxLeft + 10, fBoxTop + 06); // middle line
end;
end;
end;
{-------------------------------------------------------------------}
procedure Register;
begin
RegisterComponents('Samples', [TCheckBoxX]);
end;
{-------------------------------------------------------------------}
destructor TCheckBoxX.Destroy;
begin
inherited Destroy;
end;
{-------------------------------------------------------------------}
constructor TCheckBoxX.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Height := 17;
Width := 97;
fChecked := False;
fColor := clBtnFace;
fState := cbUnChecked;
fFont := inherited Font;
fAllowGrayed := False;
fFocus := False;
fMouseState := msMouseUp;
fAlignment := taRightJustify;
TabStop := True; // Sorry
end;
{-------------------------------------------------------------------}
end.
{===================================================================}
Взято с Исходников.ru
Virtual ListView с контекстным меню
Virtual ListView с контекстным меню
В Delphi5/Demos есть пример Virtual ListView. программка чем-то напоминает explorer, но без контекстного меню. контекстное меню приделывается так:
procedure TForm1.PopupMenu1Popup(Sender: TObject);
var
ContextMenu : IContextMenu;
menu : HMENU;
begin
FIShellFolder.GetUIObjectOf(Handle, 1, ShellItem(ListView.Selected.Index).ID,
IID_IContextMenu, nil, ContextMenu);
menu := CreatePopupMenu();
ContextMenu.QueryContextMenu(menu, 0, 1, $7FFF, CMF_EXPLORE);
TrackPopupMenu(menu,
TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD,
Mouse.CursorPos.x, Mouse.CursorPos.y, 0, Handle, nil);
DestroyMenu(menu);
end;
Взято с Исходников.ru
Визуальные компоненты для DB
Визуальные компоненты для DB
Итак, мы не написав ни строчки кода получили простейшее приложение, работающее с базой данных. С помощью него мы можем просматривать и редактировать содержимое таблицы. Давайте теперь сделаем эту процедуру немного удобнее, на закладке "Data Control" есть компонент TDBNavigator. Положим его на форму и в инспекторе объектов поставим его свойство DataSource указывающим на тот же DataSource1, что и для DBGrid - собственно, теперь оба визуальных контрола(DBGrid и DBNavigator) привязаны к одному и тому же DataSource и через него к одной и той же таблицы. DBNavigator имеет несколько кнопок (вы можете настроить какие именно вы хотите видеть) дающие лёгкий контроль над следующими операциями:
(перечисление в порядке расположения кнопок)
1)Переход на первую запись
2)Переход на предыдущую запись
3)Переход на следующую запись
4)Переход на последнюю запись
5)Добавить запись
6)Удалить запись
7)Редактировать запись
8)Сохранить изменения
9)Отменить изменения
10)Перечитать таблицу
Обратите внимание, что запись (строка) таблицы есть как бы неделимый квант информации - т.е. отменяются действия произведенные для всей записи целиком, добавляется или удаляется тоже строка целиком.
Разберём ещё несколько визуальных компонентов, чтобы покончить с визуализацией данных и перейти собственно к программированию.
На закладке Data Controls есть ещё несколько важных компонентов, давайте поставим их на нашу форму: DBLabel, DBEdit, DBMemo и DBImage. Все их так же как и DBGrid соединим с DataSource1. Однако здесь мы обнаружим что этого недостаточно, эти компоненты работают с отдельной ячейкой в таблице, поэтому мы должны указать ещё поле (столбец) который они будут показывать.
Давайте сделаем следуюшие - для каждого из этих компонентов укажем свойство DataField, например следующим образом:
DBLabel - ассоциируем с полем Category
DBEdit - ассоциируем с полем Common_name
DBMemo - ассоциируем с полем Notes
DBImage - ассоциируем с полем Graphic
Можно откомпилировать программу и немного поиграться с ней. Итак что мы можем здесь увидеть? Что в каждый данный момент времени из всей таблицы у нас есть запись которая активная (текущая) - в DBGrid она показывается треугольничком слева. Именно с этой единственной записью мы и можем оперировать - удалять, добавлять, редактировать, именно её содержимое отображается в DBLabel, DBEdit, DBMemo, DBImage и именно она может быть изменена при помощи этих компонентов. Описанная только что структура позволяет работать только с одной записью в определённый момент времени, если вы переходите на другую запись то все изменения должны быть либо запомнены либо отменены! По умолчанию они запоминаются без всяких запросов, в чём вы можете убедиться меняя значения и переходя на другую запись.
Включение и выключение устройств ввода/вывода
Включение и выключение устройств ввода/вывода
Иногда может возникнуть необходимость в выключении на время устройств ввода - клавиатуры и мыши. Например, это неплохо сделать на время выполнения кода системы защиты от копирования, в играх, или в качестве "наказания" при запуске программы по истечению срока ее бесплатного использования ... . Однако наилучшее ее применение - отключение клавиатуры и мыши на время работы демонстрационки, основанной на воспроизведении записанных заранее перемещений мышки и клавиатурного ввода (см. об этом отдельный раздел этой книги). Это элементарно сделать при помощи API:
EnableHadwareInput(Enable:boolean): boolean;
Enable - требуемое состояние устройств ввода (True - включены, false - выключены). Если ввод заблокирован, то его можно разблокировать вручную - нажать Ctrl + Alt + Del, при появлении меню "Завершение работы программы" ввод разблокируется.
А вот еще интересный прикол.
Включение/выключение монитора программным способом.
Предупреждаю сразу! После того, как вы отключите монитор, просто так вы его уже не включите (хотя это может быть зависит от монитора, я, во всяком случае, не смог). Только после перезагрузки компьютера.
Отключить :
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
Включить :
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
Источник:
Внести изменения в набор данных и не потерять текушей позиции
Внести изменения в набор данных и не потерять текушей позиции
procedureTMyForm.MakeChanges;
var
aBookmark: TBookmark;
begin
Table1.DisableControls;
aBookmark := Table.GetBookmark;
try
{ваш код}
finally
Table1.GotoBookmark(aBookmark);
Table1.FreeBookmark(aBookmark);
Table1.EnableControls;
end;
end
Взято из
Вопросы инсталяции програм
Вопросы инсталяции програм
Cодержание раздела:
См. также статьи в других разделах:
См. также другие разделы:
Вопросы локализации програм
Вопросы локализации програм
Cодержание раздела:
Вопросы оптимизации и отладки програм
Вопросы оптимизации и отладки програм
Cодержание раздела:
См. также статьи в других разделах:
Вопросы защиты и взлома програм
Вопросы защиты и взлома програм
Cодержание раздела:
См. также статьи в других разделах:
См. также другие разделы:
Восстановление минимизированного приложения
Восстановление минимизированного приложения
При минимизации формы я использую RxTrayIcon, чтобы при этом исчезла
кнопка из Панели задач вызываю ShowWindow(Application.Handle,SW_HIDE).
Но вот незадача - не получается при восстановлении приложения (после клика
на TrayIcon) добиться, чтобы оно становилось поверх других окон и обязательно было активным.
Дело оказалось в следующем : гасить Tray-иконку надо в последнюю очередь,
именно так все работает(ранее сначала гасил Tray-иконку, а уже потом восттанавливал свое приложение).
Таким образом правильно работает следующий код:
procedure TForm1.ApplicationMinimize(Sender : TObject);
begin
RxTrayIcon1.Show;
ShowWindow(Application.Handle,SW_HIDE);
end;
procedure TForm1.RxTrayIcon1Click(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Application.Restore;
SetForeGroundWindow(Application.MainForm.Handle);
RxTrayIcon1.Hide;
end;
Авторы ответа: Song, Den
Взято с Vingrad.ru
Восстановление записи dBase
Восстановление записи dBase
functionGetTableCursor(oTable: TTable): hDBICur;
var
szTable: array[0..78] of Char;
begin
StrPCopy(szTable, oTable.TableName);
DbiGetCursorForTable(oTable.DBHandle, szTable, nil, Result);
end;
function dbRecall(oTable: TTable): DBIResult;
begin
Result := DbiUndeleteRecord(GetTableCursor(oTable)));
end;
Предположим, у вас на форме имеется кнопка (с именем 'butRecall'), восстанавливающая текущую отображаемую (или позиционируемую курсором) запись, данный код, будучи расположенный в обработчике события кнопки OnClick (вместе с опубликованным выше кодом), это демонстрирует (продвигаясь в наших предположених дальше, имя вашего объекта TTable - Table1 и имя текущей формы - Form1):
procedure TForm1.butRecallClick(Sender: TObject);
begin
if dbRecall(Table1) <> DBIERR_NONE then
ShowMessage('Не могу восстановить запись!');
end;
- Loren Scott
Взято из
Советов по Delphi от
Сборник Kuliba
Возникает сложность копирования MS Access
Возникает сложность копирования MS Access
Говорит мол невозможно открыть файл. И на самом деле еще виден файл блокировки Access. Как закрыть базу так чтоб этот файл исчез и я мог сохранить.
Ответ:
session.close
Автор Vit
Взято с Vingrad.ru
Вращение объектов
Вращение объектов
Здесь я бы хотел рассказать не о том, как работать с DelphiX, OpenGL или Direct, а о том, как можно вращать многогранники с помощью простых действий: moveto и lineto.
Здесь рассмотрим пример вращения куба. Будем рисовать на Canvase (например Listbox). Сначала нарисуем врашающийся квадрат (точнее 2 квадрата и соединим их). Пусть q - угол поворота квадрата, который мы рисуем. Очевидно, что нам надо задать координаты вершин квадрата - a:array [1..5,1..2] of integer. 1..4+1 - количество вершин квадрата (почему +1 будет объяснено позже). 1..2 - координата по X и Y. Кто учился в школе, наверное помнит, что уравнение окружности: X^2+Y^2=R^2, кто хорошо учился в школе, возможно вспомнит уравнение эллипса: (X^2)/(a^2)+ (Y^2)/(b^2)=1. Но это нам не надо. Нам понадобится уравнение эллипса в полярных координатах: x=a*sin(t); y=a*cos(t);t=0..2*PI; (учащиеся университетов и институтов ликуют).
С помощью данного уравнения мы заполняем массив с координатами.
fori:=1 to 5 do
begin
// координата по Х; q+i*pi/2 - угол поворота
// i-той вершины квадрата.
a[i,1]:=trunc(80*sin(q+i*pi/2));
// координата по Y; знак минус - потому что координаты
// считаются с верхнего левого угла
a[i,1]:=trunc(-30*cos(q+i*pi/2));
end;
Сейчас будем рисовать квадрат:
for i:=1 to 4 do
begin
moveto(100+a[i,1],50+a[i,2]); //Встаем на i-ую точку квадрата.
lineto(100+a[i+1,1],50+a[i+1,2]); //Рисуем линию к i+1-ой точке.
Вот почему array[1..5,1..2], иначе - выход за границы. end;
Затем рисуем второй такой же квадрат, но пониже (или повыше). Соединяем линиями первый со вторым:
for i:=1 to 4 do
begin
moveto(100+a[i,1],50+a[i,2]);
lineto(100+a[i,1],130+a[i,2]);
end;
Осталось очистить Listbox, увеличить q и сделать сначала. Все!!!
Можно также скрывать невидимые линии - когда q находится в определенном интервале. Также можно поизвращаться: повернуть куб в другой плоскости - поворот осей(для тех, кто знает формулу).
Автор: Айткулов Павел
WEB-сайт: http://rax.ru/click?apg67108864.narod.ru/
Взято из
Всё о файлах (Статья)
Всё о файлах (Статья)
Решил здесь собрать воедино основные приемы работы с файлами.
Автор
VitВзято с Vingrad.ru
Вскрытие запароленной таблицы Paradox
Вскрытие запароленной таблицы Paradox
Предупрежден - значит, вооружен. Берем Парадоксовскую табличку, паролим ее самым секретным паролем, бумажку с паролем сжигаем, а сам пароль забываем. Что теперь делать? Да ничего, просто открываем нашу табличку с одним из паролей: jIGGAe, nx66ppx, cupcdvum. Один, да подойдет.
Взято из
Советов по Delphi от
Сборник Kuliba
Вставка одних компонентов в другие
Вставка одних компонентов в другие
Cодержание раздела:
См. также статьи в других разделах:
Встроенные форматы буфера обмена
Встроенные форматы буфера обмена
Автор: Peter Below
procedureTForm1.BtnShowFormatsClick(Sender: TObject);
var
buf: array[0..60] of Char;
n: Integer;
fmt: Word;
name: string[30];
begin
MemFormats.Clear;
for n := 0 to Clipboard.FormatCount - 1 do
begin
fmt := Clipboard.Formats[n];
if GetclipboardFormatName(fmt, buf, Pred(Sizeof(buf))) <> 0 then
MemFormats.Lines.Add(StrPas(buf))
else
begin
case fmt of
1: name := 'CF_TEXT';
2: name := 'CF_BITMAP';
3: name := 'CF_METAFILEPICT';
4: name := 'CF_SYLK';
5: name := 'CF_DIF';
6: name := 'CF_TIFF';
7: name := 'CF_OEMTEXT';
8: name := 'CF_DIB';
9: name := 'CF_PALETTE';
10: name := 'CF_PENDATA';
11: name := 'CF_RIFF';
12: name := 'CF_WAVE';
13: name := 'CF_UNICODETEXT';
14: name := 'CF_ENHMETAFILE';
15: name := 'CF_HDROP (Win 95)';
16: name := 'CF_LOCALE (Win 95)';
17: name := 'CF_MAX (Win 95)';
$0080: name := 'CF_OWNERDISPLAY';
$0081: name := 'CF_DSPTEXT';
$0082: name := 'CF_DSPBITMAP';
$0083: name := 'CF_DSPMETAFILEPICT';
$008E: name := 'CF_DSPENHMETAFILE';
$0200..$02FF: name := 'частный формат';
$0300..$03FF: name := 'Объект GDI';
else
name := 'неизвестный формат';
end;
MemFormats.Lines.Add(name);
end;
end;
end;
Взято с
COM при программировании на Delphi
Автор Бин ЛиЯ всегда твердо верил, что нет ничего такого, что было бы невозможно понять. Необходимо только "выпарить" наиболее сложные части проблемы и потратить какое-то количество времени на понимание частей проблемы "кусок за куском". Затем эти части собрать вместе и понять проблему целиком.
Потоковые модели в COM имеют репутацию наиболее сложных для понимания. Возможно потому, что множество имеющейся документации по этой теме имеет "техническую природу" или ориентировано на конкретный язык, чаще всего C или C++. Цель этой статьи - дать Вам возможность понять, почему потоковые модели в COM так важны и как правильно использовать потоковые модели в Ваших приложениях COM. Моя цель - представить Вам материал таким образом, чтобы Вы могли читать его последовательно от начала до конца и в результате понять всю статью. Сказав это, я бы настойчиво рекомендовал Вам не пропускать ни одной страницы в процессе чтения, чтобы у Вас не возникло трудностей оттого, что Вы что-то пропустили раньше. А теперь, я желаю Вам удачи, и не говорите, что я не предупреждал Вас об этом!
Прежде, чем начать изложение, давайте начнем с того, что поймем, почему потоковые модели так важны для Ваших приложений COM. Исходя из своего опыта, я могу сказать, что наиболее существенной причиной использования потоковых моделей является повышение общей производительности и скорости реакции Вашей программы, особенно для объектов серверов COM, которые используются для обслуживания большого количества клиентских приложений. Но я не хочу сказать, что использование потоковых моделей в Ваших объектах серверов COM всегда увеличивает производительность. Вы должны тщательно изучить, как используются Ваши объекты и как потоковая модель повлияет на производительность приложения и целостность данных. Я должен подчеркнуть, что вопросы целостности обязательно должны рассматриваться объектов при принятии решения, применять или нет потоковую модель.
Несмотря на то, что Вы можете думать, что использование потоковой модели существенно повысит производительность объекта, может оказаться, что Ваши объекты сильно зависят, скажем, от третьих библиотек, которые могут "не выжить" в условиях многопоточности. Другой хорошей причиной применения многопоточности может быть то, что задача по своей природе является весьма пригодной для многопоточной реализации. Например, серверные объекты, являющиеся чисто служебными объектами, вероятно, могут сильно зависеть от времени при выполнении операций или захватывании ресурсов. Примерами таких объектов являются мониторы работы оборудования, объекты пакетной обработки или даже простые объекты манипулирования данными, время исполнения которых для успешного завершения непредсказуемо. В этих случаях тип разрабатываемого Вами приложения по существу определяет использование многопоточности.
Имеется множество других причин, при которых Вы могли бы использовать многопоточность, но две упомянутые выше причины являются наиболее общими среди наблюдаемых в промышленном программировании.
С другой стороны, я бы хотел предупредить, что не стоит применять многопоточность, если Вы не нуждаетесь в ней или не можете понять преимущества получаемого при этом решения. Это означает, что Вам не стоит даже думать о многопоточности, если Вы думаете только о том, что это круто. Поверьте мне, использование мнопоточности существенно усложняет Ваше приложение и, если Вы недостаточно все продумали, Вам придется искать ошибки в тех местах программы, которые прекрасно работали в однопоточном исполнении.
Ввести пароль Paradox
Ввести пароль Paradox
Как мне при соединении с таблицей Paradox устранить/"удовлетворить" окошко с требованием ввести пароль, защищающей таблицу?
Свойство компонента Table ACTIVE должно быть установлено в FALSE. (Если она активна прежде, чем вы ввели пароль, вы получите это окошко.) Затем поместите следующий код в обработчике события формы OnCreate:
session.AddPassword('Мойсекретный пароль');
table1.active := true;
Взято из
Советов по Delphi от
Сборник Kuliba
Вычисление интеграла
Вычисление интеграла
Вычисление интеграла с заданной точностью алгоритмом Симпсона.
//(c) Copydown 2002, all left reserved. http://world.fpm.kubsu.ru.
{$APPTYPE CONSOLE}
{$F+} {разрешение передачи функций, как параметров}
type FunctionType = function(x: real): real;
{интегрируемая функция}
function f(x: real): real; begin f := x end;
{интегрирование от a до b функции f с точностью e}
function IntegralSimpson(a, b: real; f: FunctionType; e: real): real;
var
h, x, s, s1, s2, s3, sign: real;
begin
if (a = b) then
begin
IntegralSimpson := 0; exit
end;
if (a > b) then
begin
x := a; a := b; b := x; sign := -1
end
else sign:=1;
h := b - a; s := f(a) + f(b); s2 := s;
repeat
s3 := s2; h := h/2; s1 := 0; x := a + h;
repeat
s1 := s1 + 2*f(x); x := x + 2*h;
until (not(x < b));
s := s + s1; s2 := (s + s1)*h/3; x := abs(s3 - s2)/15
until (not(x > e));
IntegralSimpson := s2*sign;
end;
begin
{вывод результата интегрирования от 0 до 1 функции f с точностью 0.001}
writeln(IntegralSimpson(0, 1, f, 0.001));
writeln; writeln('Press Enter'); readln;
end.
Взято с
Выключение питания ATX коpпуса из-под DOS
Выключение питания ATX коpпуса из-под DOS
movax,5301h
sub bx,bx
int 15h
jb stop
mov ax,530eh
sub bx,bx
int 15h
jb stop
mov ax,5307h
mov bx,0001h
mov cx,0003h
int 15h
stop: int 20h
Код прислал Колесников Сергей Александрович [mailto:rovd@inbox.ru]
Взято из
Советов по Delphi от
Сборник Kuliba
Выполнение процедуры по адресу
Выполнение процедуры по адресу
varF: procedure(x, y: double);
@F := GetProcAddress(hDLL, 'SOMEPROC');
F(3, 4);
Ключом здесь является использование оператора @, располагаемого с левой части процедурной переменной. Он говорит компилятору: "Не волнуйтесь здесь о совместимости типов, просто присвойте полученный в правой части выражения адрес переменной в левой части выражения (и процедурные переменные являются переменными-указателями).
- Peter Below
Взято из
Советов по Delphi от
Сборник Kuliba
Выполнение запросов к базе данных в фоне
Выполнение запросов к базе данных в фоне
Данный документ объясняет как выполнить запрос в фоновом режиме, используя класс TThread. Для получения общей информации о классе TThread, пожалуйста обратитесь к документации Borland и электронной справке. Для понимания данного документа вам необходимо иметь представление о том, как работать с компонентами для работы с базами данных, поставляемых в комплекте с Delphi 2.0.
Для осуществления потокового запроса необходимо выполнение двух требований. Во-первых, потоковый запрос должен находиться в своей собственной сессии с использованием отдельного компонента TSession. Следовательно, на вашей форме должен находиться компонент TSession, имя которого должно быть назначено свойству SessonName компонента TQuery, используемого для выполнения потокового запроса. Для каждого используемого в потоке компонента TQuery вы должны использовать отдельный компонент TSession. При использовании компонента TDataBase, для отдельного потокового запроса должен также использоваться отдельный TDataBase. Второе требование заключается в том, что компонент TQuery, используемый в потоке, не должен подключаться в контексте это потока к TDataSource. Это должно быть сделано в контексте первичного потока.
Приведенный ниже пример кода иллюстрирует описываемый процесс. Данный модуль демонстрирует форму, которая содержит по два экземпляра следующих компонентов: TSession, TDatabase, TQuery, TDataSource и TDBGrid. Данные компоненты имеют следующие значения свойств:
Session1
Active True;
SessionName "Ses1"
DataBase1
AliasName "IBLOCAL"
DatabaseName "DB1"
SessionName "Ses1"
Query1
DataBaseName "DB1"
SessionName "Ses1"
SQL.Strings "Select * from employee"
DataSource1
DataSet ""
DBGrid1
DataSource DataSource1
Session2
Active True;
SessionName "Ses2"
DataBase2
AliasName "IBLOCAL"
DatabaseName "DB2"
SessionName "Ses2"
Query2
DataBaseName "DB2"
SessionName "Ses2"
SQL.Strings "Select * from customer"
DataSource2
DataSet ""
DBGrid1
DataSource DataSource2
Обратите внимание на то, что свойство DataSet обоих компонентов TDataSource первоначально никуда не ссылается. Оно устанавливается во время выполнения приложения, и это проиллюстрировано в коде.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables;
type
TForm1 = class(TForm)
Session1: TSession;
Session2: TSession;
Database1: TDatabase;
Database2: TDatabase;
Query1: TQuery;
Query2: TQuery;
DataSource1: TDataSource;
DataSource2: TDataSource;
DBGrid1: TDBGrid;
DBGrid2: TDBGrid;
GoBtn1: TButton;
procedure GoBtn1Click(Sender: TObject);
end;
TQueryThread = class(TThread)
private
FSession: TSession;
FDatabase: TDataBase;
FQuery: TQuery;
FDatasource: TDatasource;
FQueryException: Exception;
procedure ConnectDataSource;
procedure ShowQryError;
protected
procedure Execute; override;
public
constructor Create(Session: TSession; DataBase:
TDatabase; Query: TQuery; DataSource: TDataSource);
virtual;
end;
var
Form1: TForm1;
implementation
constructor TQueryThread.Create(Session: TSession; DataBase: TDatabase; Query:
TQuery; Datasource: TDataSource);
begin
inherited Create(True); // Создаем поток c состоянием suspendend
FSession := Session; // подключаем все privat-поля
FDatabase := DataBase;
FQuery := Query;
FDataSource := Datasource;
FreeOnTerminate := True;
// Устанавливаем флаг освобождения потока после его завершения
Resume; // Продолжение выполнения потока
end;
procedure TQueryThread.Execute;
begin
try
{ Выполняем запрос и подключаем источник данных к компоненту TQuery,
вызывая ConnectDataSource из основного потока
(для этой цели используем Synchronize)}
FQuery.Open;
Synchronize(ConnectDataSource);
except
{ Ловим исключение (если оно происходит) и его дескриптор
в контексте основного потока (для этой цели используем
Synchronize). }
FQueryException := ExceptObject as Exception;
Synchronize(ShowQryError);
end;
end;
procedure TQueryThread.ConnectDataSource;
begin
FDataSource.DataSet := FQuery; // Подключаем DataSource к TQuery
end;
procedure TQueryThread.ShowQryError;
begin
Application.ShowException(FQueryException); // Обрабатываем исключение
end;
procedure RunBackgroundQuery(Session: TSession; DataBase: TDataBase; Query:
TQuery; DataSource: TDataSource);
begin
{ Создаем экземпляр TThread с различными параметрами. }
TQueryThread.Create(Session, Database, Query, DataSource);
end;
{$R *.DFM}
procedure TForm1.GoBtn1Click(Sender: TObject);
begin
{ Запускаем два отдельных запроса, каждый в своем потоке }
RunBackgroundQuery(Session1, DataBase1, Query1, Datasource1);
RunBackgroundQuery(Session2, DataBase2, Query2, Datasource2);
end;
end.
Метод TForm1.GoBtn1Click является обработчиком события нажатия кнопки. Данный обработчик события дважды вызывает процедуру RunBackgroundQuery, это случается при каждой передаче новых параметров компонентам для работы с базой данных. RunBackgroundQuery создает отдельный экземпляр класса TQueryThread, передает различные компоненты для работы с базой данных в его конструктор, который, в свою очередь, назначает их закрытым полям TQueryThread.
TQueryThread содержит две определенные пользователем процедуры: ConnectDataSource и ShowQryError. ConnectDataSource связывает FDataSource.DataSet с FQuery. Тем не менее, это делается в первичном потоке с помощью метода TThread.Synchronize. ShowQryError обрабатывает исключение в контексте первиного потока, также используя метод Synchronize. Конструктор Create и метод Execute снабжены подробными комментариями.
Взято из
Выполняем встроенные команды Windows
Выполняем встроенные команды Windows
Автор:
Ruslan Abu ZantКомпилятор: Delphi 4.x (или выше)
Впринципе эти команды можно запускать в меню "Выполнить..." (Run), кнопки Пуск. Ну а в Delphi они запускаются путём всем извесной команды winexec(Pchar('ABCD'),sw_Show);
где 'ABCD' - одна из следующих команд ...
"rundll32 shell32,Control_RunDLL" - Запустить Панель Управления
"rundll32 shell32,OpenAs_RunDLL" - Открыть диалог "Открыть Как ..." ('Open With...')
"rundll32 shell32,ShellAboutA Info-Box" - Открыть 'About Window Window'
"rundll32 shell32,Control_RunDLL desk.cpl" - Открыть диалог "Свойства: Экран" (Display Properties)
"rundll32 user,cascadechildwindows" - Выстроить все окна каскадно
"rundll32 user,tilechildwindows" - Свернуть все окна
"rundll32 user,repaintscreen" - Обновить Десктоп
"rundll32 shell,shellexecute Explorer" - Перезапустить Проводник
"rundll32 keyboard,disable" - Заблокировать Клавиатуру
"rundll32 mouse,disable" - Запретить мышку
"rundll32 user,swapmousebutton" - Поменять кнопки мыши
"rundll32 user,setcursorpos" - Установить Курсор в позицию (0,0)
"rundll32 user,wnetconnectdialog" - Показать диалог "Подключить сетевой диск" ('Map Network Drive')
"rundll32 user,wnetdisconnectdialog" - Показать диалог "Отключить сетевой диск" ('Disconnect Network Disk')
"rundll32 user,disableoemlayer" - Отобразить окно BSOD ('''(BSOD) = Blue Screen Of Death ''')
"rundll32 diskcopy,DiskCopyRunDll" - Показать диалог копирования диска
"rundll32 rnaui.dll,RnaWizard" - Запустить 'Internet Connection Wizard'
"rundll32 shell32,SHFormatDrive" - Запустить окно форматирования дискеты ('Format Disk (A)')
"rundll32 shell32,SHExitWindowsEx -1" - "Холодный" перезапуск Проводника
"rundll32 shell32,SHExitWindowsEx 1" - Выключить компьютер
"rundll32 shell32,SHExitWindowsEx 0" - Завершить сеанс текущего пользователя
"rundll32 shell32,SHExitWindowsEx 2" Быстрый перезапуск Windows9x
"rundll32 krnl386.exe,exitkernel" - Выход из Windows 9x без потверждения
"rundll rnaui.dll,RnaDial "MyConnect" - Запустить диалог 'Net Connection'
"rundll32 msprint2.dll,RUNDLL_PrintTestPage" - Выбор и печать тестовой страницы текущего принтера
"rundll32 user,setcaretblinktime" - Усатновить скорость мигания курсора
"rundll32 user, setdoubleclicktime" - Установить скорость двойного нажатия
"rundll32 sysdm.cpl,InstallDevice_Rundll" - Поиск устройств не PnP.
Взято с Исходников.ru
