nyuuzyou/wikis huggingface dataset:
Oracle иTStoredProc

=== Oracle иTStoredProc ===
Недавно я перешел на использование Oracle, и все мои попытки использовать компонент TStoredProc кончаются неудачей. Почему?
Причины неработоспособности компонента TStoredProc могут быть следующими. Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают). И во-вторых, имеется известная проблема, описание которой содержится в разделе Developers support корпоративного сайта Inprise. Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.
 Наталия Елманова
 Компьютер Пресс - CD, 1999, N 8 Copyright N.Elmanova & ComputerPress Magazine
ID: 02717
Override/Vitual/Dynamic - методы

=== Override/Vitual/Dynamic - методы ===
Если метод в классе предка объявлен как виртуальный (virtual) или динамический (dynamic), вам необходимо перекрыть его во всех классах-наследниках. Если вы объявляете унаследованный метод виртуальным или динамическим, вы начинаете строить его новое виртуальное/динамическое дерево наследования. Допустим, у нас есть следующая иерархия: A (родитель) - B - C - D. Если вы объявляете метод как виртуальный (или динамический) в A, перекрываете в B, создаете виртуальным в C и перекрываете в D, вот что получается:
 фактический класс, используемый класс, использующий
 класс для доступа к методу метод
 -----------+---------------------+--------------------
 D D D
 D C D
 D B B
 D A B
 
 C C C
 C B B
 C A B
 
 B B B
 B A B
Вывод: работа виртуального/динамического наследования прекращается в момент создания одноименного виртуального/динамического метода наследниками класса.
Author: Mark
Source: из Советов по Delphi от Валентина Озерова, Сборник Kuliba
ID: 00115
OwnerDraw в компоненте StatusBar

=== OwnerDraw в компоненте StatusBar ===
procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
 Panel: TStatusPanel; const Rect: TRect);
begin
 with statusbar1.Canvas do
 begin
 Brush.Color := clRed;
 FillRect(Rect);
 TextOut(Rect.Left, Rect.Top, 'Панель '+IntToStr(Panel.Index));
 end;
end;
Source: http://delphiworld.narod.ru/
ID: 00953
PChar → Integer

=== PChar --> Integer ===
Many Windows functions claim to want PChar parameters in the documentation, but they are defined as requiring LongInts. 
Is this a bug? 
No, this is where "typecasting" is used. Typecasting allows you to fool the compiler into thinking that one type of variable is of another type for the ultimate in flexibility. The last parameter of the Windows API function SendMessage() is a good example. It is 
documented as requiring a long integer, but commonly requires a PChar for some messages (WM_WININICHANGE). Generally, the variable you are typecasting from must be the same size as the variable type you are casting it to. In the SendMessage example, you could typecast a PChar as a longint, since both occupy 4 bytes of memory: 
var 
 S: array[0..64] of char; 
begin 
 StrCopy(S, 'windows'); 
 SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); 
end; 
Language: en
ID: 00147
PID and SID процесса

=== PID and SID процесса ===
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls;
type
 TForm1 = class(TForm)
 Button1: TButton;
 procedure Button1Click(Sender: TObject);
 end;
 PTokenUser = ^TTokenUser;
 TTokenUser = record
 User: array[0..0] of TSIDAndAttributes;
 end;
 procedure ConvertSidToStringSid(SID: PSID; var StringSid: LPSTR); stdcall;
 external advapi32 name 'ConvertSidToStringSidA';
var
 Form1: TForm1;
implementation
{$R *.dfm}
function GetCurrentUserSID: String;
var
 TokenHandle: THandle;
 TokenInformationClass: TTokenInformationClass;
 TokenInformation: PTokenUser;
 ReturnLength: DWORD;
 StringSid: LPSTR;
begin
 Result := ;
 if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, TokenHandle) then
 try
 TokenInformationClass := TokenUser;
 GetTokenInformation(TokenHandle, TokenInformationClass, nil, 0, ReturnLength);
 if GetLastError = ERROR_INSUFFICIENT_BUFFER then
 begin
 TokenInformation := GetMemory(ReturnLength);
 if TokenInformation <> nil then
 try
 if GetTokenInformation(TokenHandle, TokenInformationClass,
 TokenInformation, ReturnLength, ReturnLength) then
 begin
 ConvertSidToStringSid(TokenInformation^.User[0].Sid, StringSid);
 Result := StringSid;
 end;
 finally
 FreeMemory(TokenInformation);
 end;
 end;
 finally
 CloseHandle(TokenHandle);
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 ShowMessage(GetCurrentUserSID);
end;
end.
В данном примере GetCurrentProcess можно заменить (если имеешь PID) на
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, True, PID);
if hProcess <> 0 then
try
 // теперь заменяй GetCurrentProcess значением из hProcess
finally
 CloseHandle(hProcess);
end;
Author: Rouse_
Source: Взято из http://forum.sources.ru
ID: 02125
PWideChar → String

=== PWideChar --> String ===
{ **** UBPFD *********** by kladovka.net.ru ****
>> Конвертация PWideChar в String
Copyright: Andre .v.d. Merwe
Дата: 18 июля 2002 г.
********************************************** }
function PWideToString(pw : PWideChar): string;
var
 p: PChar;
 iLen: integer;
begin
 iLen := lstrlenw(pw) + 1;
 GetMem(p, iLen);
 WideCharToMultiByte(CP_ACP, 0, pw, iLen, p, iLen * 2, nil, nil);
 Result := p;
 FreeMem(p, iLen);
end;
Source: http://kladovka.net.ru
Author: Andre .v.d. Merwe
ID: 00177
Paradox и неверные индексы Win95

=== Paradox и неверные индексы Win95 ===
Сообщение об ошибке: В файловой системе win95 существует ошибка, "микширующая" блокировку записи Paradox и механизм обновления. В хост-файлах Paradox в Windows 95 для работы нескольких пользователей измените следующие значения:
* Select Control Panel
* System (icon)
* Performance (Tab)
* File System (Button)
* Troubleshooting (Tab)
* "Disable New File Sharing and Locking Semantics" (щелкните) (нажмите OK)
* (Выключить общий доступ к новым файлам и семантику блокировки)
Author: David W. Husch 
Source: Взято с http://delphiworld.narod.ru
ID: 02958
Category:Базы данных
Category:Paradox
Popsock.pas

unit PopSock;
{
 CrtSocket for Delphi 32
 Copyright (C) 1999-2001 Paul Toth <tothpaul@free.fr>
 http://tothpaul.free.fr
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
interface
uses
 CrtSock, SysUtils;
function OpenMailBox(Server, User, Password: string): Integer;
procedure CloseMailBox;
function MailCount: Integer;
function GetMail(Index: Integer): string;
function MailError: string;
implementation
var
 popin, popout: TextFile;
 last: string;
 Read: Boolean;
function MailError: string;
begin
 Result := last;
end;
function ReadString: string;
begin
 repeat
 ReadLn(popin, Result);
 until (Length(Result) < 4) or (Result[4] <> '-');
 last := Result;
end;
procedure WriteString(s: string);
begin
 WriteLn(popout, s);
end;
function Status: Char;
var
 s: string;
begin
 s := ReadString;
 if s = then Status := '?'
 else
 Status := s[1];
end;
function Exec(cmd: string): Char;
begin
 WriteString(cmd);
 Result := Status;
end;
function OpenMailBox(Server, User, Password: string): Integer;
begin
 Result := CallServer(Server, 110);
 if Result > 0 then
 begin
 AssignCrtSock(Result, popin, popout);
 if Status = '+' then
 begin
 if (Exec('USER ' + User) = '+') and (Exec('PASS ' + Password) = '+') then exit;
 Disconnect(Result);
 Result := -3;
 end
 else
 begin
 Disconnect(Result);
 Result := -2;
 end;
 end;
end;
procedure CloseMailBox;
begin
 Exec('QUIT');
 CloseFile(popout);
end;
function MailCount: Integer;
var
 i: Integer;
begin
 Result := -1;
 if Exec('STAT') <> '+' then exit;
 i := pos(' ', Last);
 if i = 0 then exit;
 while Last[i] = ' ' do Inc(i);
 Result := 0;
 while (i < Length(Last)) and (Last[i] in ['0'..'9']) do
 begin
 Result := 10 * Result + Ord(Last[i]) - Ord('0');
 Inc(i);
 end;
end;
function GetMail(Index: Integer): string;
var
 s: string;
begin
 WriteLn(popout, 'RETR ', Index);
 Result := ;
 if Status = '+' then
 begin
 ReadLn(popin, s);
 while s <> do
 begin
 Result := Result + s + #13#10; // header
 ReadLn(popin, s);
 end;
 repeat
 Result := Result + s + #13#10; // body
 ReadLn(popin, s);
 until s = '.';
 end;
end;
end.
Category:Связь
Category:Сокеты
ProgressBar, который не отображают реального прогресса

=== ProgressBar, который не отображают реального прогресса ===
Начиная с виньХР появились в системе забавные ProgressBar'ы, которые не отображают реального "прогресса", а лишь отображают, что что-нибудь работает... такой же появляется при загрузки виндыХР (бегает пару чёрточек слева вправо, а потом обратно возвращаются в начало). Такой же прогресс отображается если в ХР выбрать изображение, в меню нажать на Print (Печать), и в этом диалоге при выборе шаблона печати - тоже такого стиля есть прогресс. (надеюсь, что теперь ясно что я имел в виду )
И сам вопрос: как такой сделать на делфи? 
Судя по MSDN, надо
const
 PBS_MARQUEE = $08;
 PBM_SETMARQUEE = WM_USER+10;
begin
 with ProgressBar1 do
 begin
 SetWindowLong (Handle, GWL_STYLE, (GetWindowLong (Handle, GWL_STYLE) or PBS_MARQUEE));
 Perform(PBM_SETMARQUEE, 1, 50);
 end;
end;
( вместо 50 поставь время перемещения кубиков )
 Цитата (MSDN) 
 Use this message when you do not know the amount of progress toward completion but wish to indicate that progress is being made. 
PS: чтобы это работало, нужно включить в прогу XP-манифест 
Author: p0s0l
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 00525
ProgressBar в колонке TListView

=== ProgressBar в колонке TListView ===
procedure TForm1.Button1Click(Sender: TObject); 
var 
 r: TRect; 
 pb: TProgressBar; 
begin 
 Listview1.Columns.Add.Width := 100; 
 Listview1.Columns.Add.Width := 200; 
 Listview1.ViewStyle := vsReport; 
 Listview1.Items.Add.Caption := 'Text'; 
 r := Listview1.Items[0].DisplayRect(drBounds); 
 r.Left := r.Left + Listview1.columns[0].Width; 
 r.Right := r.Left + Listview1.columns[1].Width; 
 pb := TProgressBar.Create(Self); 
 pb.Parent := Listview1; 
 pb.BoundsRect := r; 
 pb.Position := 30; 
 Listview1.Items[0].Data := pb; 
end; 
// Change the ProgressBar Position 
// ProgressBar Position andern 
procedure TForm1.Button2Click(Sender: TObject); 
var 
 pb: TProgressBar; 
begin 
 pb := TProgressBar(Listview1.Items[0].Data); 
 pb.StepIt; 
end;
Source: http://delphiworld.narod.ru/
ID: 00964
ProgressBar с невидимой рамкой

=== ProgressBar с невидимой рамкой ===
Заказчик моего проекта обратился с просьбой - "Сделать прогресс индикатор как в приложениях Нортона. Чтоб был в статус строке и НИКАКИХ рамок". ProgressBar в StatusBar - нет проблем, но как быть с рамкой от ProgressBar? ProgressBar всегда вычерчивает рамку и не имеет методов ее управления. Однако появилась интересная идея, воплотившаяся в компонент с новым свойством ShowFrame. Решение оказалось на удивление простым. На рисунке сравнение стандартного ProgressBar и ProgressBar с невидимой рамкой.
unit vsprgs;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 ComCtrls;
type
 TNProgressBar = class(TProgressBar)
 procedure WMNCPAINT(var Msg: TMessage); message WM_NCPAINT;
 private
 FShowFrame: boolean;
 procedure SetShowFrame(Value: boolean);
 protected
 public
 constructor Create(AOwner: TComponent); override;
 published
 property ShowFrame: boolean read FShowFrame write SetShowFrame;
 end;
procedure Register;
implementation
{ TNProgressBar }
constructor TNProgressBar.Create(AOwner: TComponent);
begin
 inherited;
 FShowFrame := True;
end;
procedure TNProgressBar.SetShowFrame(Value: boolean);
begin
 if FShowFrame <> Value then
 begin
 FShowFrame := Value;
 RecreateWnd;
 end;
end;
procedure TNProgressBar.WMNCPAINT(var Msg: TMessage);
var
 DC: HDC;
 RC: TRect;
begin
 if ShowFrame then
 begin
 inherited;
 Invalidate;
 end
 else
 begin
 DC := GetWindowDC(Handle);
 try
 Windows.GetClientRect(Handle, RC);
 with RC do
 begin
 Inc(Right, 2);
 Inc(Bottom, 2);
 end;
 Windows.FillRect(DC, RC, Brush.Handle);
 finally
 ReleaseDC(Handle, DC);
 end;
 end;
end;
procedure Register;
begin
 RegisterComponents('Controls', [TNProgressBar]);
end;
end.
Source: http://delphiworld.narod.ru/
ID: 00961
RC4

RC4:
* Симметричный алгоритм шифрования поточного вида.
* Переменная длина ключа.
* Для зашифровки/расшифровки применяют один и тот же ключ.
* Был рассекречен в середине 90-х анонимным лицом,в интернете.
///////////////////////////////////////////////////
///////////////////Шифр RC4////////////////////////
///////////////////////////////////////////////////
unit RC4;
var
 s: array [0..255] of Byte;
 i, j: Byte;
// Инициализация S-Box'а
procedure InitRC4Cipher(key: ShortString);
var
 k: array [0..255] of Byte;
 t: Byte;
 l: Cardinal;
 i0, j0: Byte;
begin
 for i0 := 0 to 255 do
 s[i0] := i0;
 j0 := 1;
 l := Length(key);
 for i0 := 0 to 255 do
 begin
 k[i0] := Ord(key[j0]);
 if j0 = l then j0 := 0;
 Inc(j0);
 end;
 for i0 := 0 to 255 do
 begin
 j0 := (j0 + k[i0] + s[i0]) mod 256;
 t := s[i0];
 s[i0] := s[j0];
 s[j0] := t;
 end;
 i := 0;
 j := 0;
end;
// Шифрование конкретного символа
function GetRC4ByteCiphered(bt: Byte): Byte;
var
 t: Byte;
begin
 i := (i + 1) mod 256;
 j := (j + s[i]) mod 256;
 t := s[i];
 s[i] := s[j];
 s[j] := t;
 t := (s[i] + s[j]) mod 256;
 Result := bt xor s[t];
end;
// Применения шифра к данным потока
function ApplyRC4ToData(InitialData: TStream; var Buffer: TStream; key: ShortString): Boolean; stdcall;
var
 i: Cardinal;
 d: Byte;
begin
 if (key = )
 or (Buffer = InitialData)
 or (Buffer = nil)
 or (InitialData = nil)
 or (InitialData.Size = 0)
 or (Buffer.Size <> 0) then
 begin
 Result := False;
 Exit;
 end;
 InitRC4Cipher(key);
 try
 InitialData.Position := 0;
 for i := 0 to InitialData.Size-1 do
 begin
 InitialData.ReadBuffer(d,1);
 d := GetRC4ByteCiphered(d);
 Buffer.WriteBuffer(d,1);
 end;
 except
 Result := False;
 Exit;
 end;
 InitialData.Position := 0;
 Buffer.Position := 0;
 Result := True;
end;
Author: Автор: MakedoneZ
Source: Взято из http://forum.sources.ru
ID: 03986
Category:Алгоритмы
Category:Шифрование
RadioButtons in a TWebbrowser

procedure TForm1.Button1Click(Sender: TObject);
var
 Document: IHTMLDocument2;
 rbTestList: IHTMLElementCollection;
 rbTest: IHTMLOptionButtonElement;
 I: Integer;
begin
 // Get a reference to the document
 Document := WebBrowser1.Document as IHTMLDocument2;
 // Get a reference to input-control (Radiobutton)
 rbTestList := Document.all.item('rating', EmptyParam) as IHTMLElementCollection;
 // Get current values.
 for I := 0 to rbTestList.Length - 1 do
 begin
 // reference to the i. RadioButton
 rbTest := rbTestList.item(I, EmptyParam) as IHTMLOptionButtonElement;
 // Show a message if radiobutton is checked
 if rbTest.Checked then
 ShowMessageFmt('Der RadioButton mit dem Wert %s' +
 ' ist ausgewahlt!', [rbTest.Value]);
 end;
 // Set new values
 for I := 0 to rbTestList.Length - 1 do
 begin
 // reference to the i. RadioButton
 rbTest := rbTestList.item(I, EmptyParam) as IHTMLOptionButtonElement;
 // check radiobutton with value 3.
 if rbTest.Value = '3' then
 rbTest.Checked := True;
 end;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03493
Category:Связь
Category:WebBrowser
Reading the autoincrement value of Paradox table

=== Reading the autoincrement value of Paradox table ===
The current highest value is stored beginning at byte 73 decimal.
The next value is determined by adding 1 to it.
Here is a simple Delphi function that returns the current
autoincrement value.
function getAutoInc(filename: string): LongInt;
var
 mystream: tfilestream;
 buffer: longint;
begin
 mystream := tfilestream.create(filename,
 fmOpenread + fmShareDenyNone);
 mystream.Seek(73, soFromBeginning);
 mystream.readbuffer(buffer, 4);
 mystream.Free;
 getAutoInc := buffer;
end;
ID: 02944
Category:Базы данных
Category:Paradox
RecCount в таблицах ASCII

=== RecCount в таблицах ASCII ===
В Delphi 1.0 для получения количества записей в ASCII файле (.TXT- и .SCH-файлы) я пользовался свойством RecordCount компонента TTable. В Delphi 2.0 эта функциональность не поддерживается! Я прав или не прав? Во всяком случае как мне получить количество записей, содержащихся в ASCII таблице?
В Delphi 2.0, свойство RecordCount отображается на недокументированную функцию BDE DbiGetExactRecordCount. Данное изменение было сделано для обеспечения правильных величин при работе с "живыми" запросами. Очевидно, данное API по какой-то причине не поддерживает текстовые файлы.
Вы можете обойти эту проблему, вызывая функцию API BDE DbiGetRecordCount напрямую (добавьте BDE к списку используемых модулей):
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word);
var
 RecCount: Integer;
begin
 Check(DbiGetRecordCount(Table1.Handle, RecCount);
end;
Source: Взято с http://delphiworld.narod.ru
ID: 02965
Category:Базы данных
Category:CSV
RichEdit замена текста

=== RichEdit замена текста ===
// This example doesn't use TReplaceDialog 
// Ohne Benutzung von TReplaceDialog 
function Search_And_Replace(RichEdit: TRichEdit; 
 SearchText, ReplaceText: string): Boolean; 
var 
 startpos, Position, endpos: integer; 
begin 
 startpos := 0; 
 with RichEdit do 
 begin 
 endpos := Length(RichEdit.Text); 
 Lines.BeginUpdate; 
 while FindText(SearchText, startpos, endpos, [stMatchCase])<>-1 do 
 begin 
 endpos := Length(RichEdit.Text) - startpos; 
 Position := FindText(SearchText, startpos, endpos, [stMatchCase]); 
 Inc(startpos, Length(SearchText)); 
 SetFocus; 
 SelStart := Position; 
 SelLength := Length(SearchText); 
 richedit.ClearSelection; 
 SelText := ReplaceText; 
 end; 
 Lines.EndUpdate; 
 end; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 Search_And_Replace(Richedit1, 'OldText', 'NewText'); 
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01017
RichEdit поиск текста

=== RichEdit поиск текста ===
function SearchForText_AndSelect(RichEdit: TRichEdit; SearchText: string): Boolean; 
var 
 StartPos, Position, Endpos: Integer; 
begin 
 StartPos := 0; 
 with RichEdit do 
 begin 
 Endpos := Length(RichEdit.Text); 
 Lines.BeginUpdate; 
 while FindText(SearchText, StartPos, Endpos, [stMatchCase])<>-1 do 
 begin 
 Endpos := Length(RichEdit.Text) - startpos; 
 Position := FindText(SearchText, StartPos, Endpos, [stMatchCase]); 
 Inc(StartPos, Length(SearchText)); 
 SetFocus; 
 SelStart := Position; 
 SelLength := Length(SearchText); 
 end; 
 Lines.EndUpdate; 
 end; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 SearchForText_AndSelect(RichEdit1, 'Some Text'); 
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01018
Richedit сам меняет язык при перемещении

=== Richedit сам меняет язык при перемещении ===
Самое главное, что мне не нравится в Richedit - это то, что он сам меняет язык при перемещении по тексту, не смотря, что вы включили нужный язык, при переходе на участок текста, набраный другим языком. 
этот баг я обхожу так. 
* я создаю потомка Richedit: 
** меню Component\New Component 
** указываю предком TRichedit
* Переписываю обработку события WM_INPUTLANGCHANGE, при этом я не вызываю обработчик предка, т.е. Richedit-а 
* Заодно обрабатываю событие WM_INPUTLANGCHANGEREQUEST, которое сообщает, что пользователь изменил язык. Тут надо вызвать обработчик предка, а то не будет переключаться язык.
Вот что из этого получилось. Имеем исправленный компонент VCL с дополнительным событием.
unit RichEditEx;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 StdCtrls, ComCtrls;
type
 TLangChangeEvent = procedure(Sender: TObject; Lang: HKL) of object;
 TRichEditEx = class(TRichEdit)
 private
 FOnLangChange: TLangChangeEvent;
 procedure WMLangRequest(var M: TMessage); message WM_INPUTLANGCHANGEREQUEST;
 procedure WMLangChange(var M: TMessage); message WM_INPUTLANGCHANGE;
 { Private declarations }
 protected
 { Protected declarations }
 public
 { Public declarations }
 published
 property OnLangChange: TLangChangeEvent read FOnLangChange write
 FOnLangChange;
 { Published declarations }
 end;
procedure Register;
implementation
procedure tricheditex.WMLangRequest(var M: TMessage);
begin
 if assigned(FOnLangChange) then
 FOnLangChange(self, m.LParam);
 inherited;
end;
procedure tricheditex.WMLangChange(var M: TMessage);
begin
 m.Result := 1;
end;
procedure Register;
begin
 RegisterComponents('Samples', [TRichEditEx]);
end;
end.
Source: http://delphiworld.narod.ru/
ID: 00676
Rotate a 2D Point

const
 PIDiv180 = 0.017453292519943295769236907684886;
{ Поворот точки (x,y) вокруг начала координат на угол RotAng }
procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double);
var
 SinVal: Double;
 CosVal: Double;
begin
 RotAng := RotAng * PIDiv180;
 SinVal := Sin(RotAng);
 CosVal := Cos(RotAng);
 Nx := x * CosVal - y * SinVal;
 Ny := y * CosVal + x * SinVal;
end;
{ Поворот точки (x,y) вокруг точки (ox,oy) на угол RotAng }
procedure RotateAround(RotAng: Double; x, y, ox, oy: Double; var Nx, Ny: Double);
begin
 Rotate(RotAng, x - ox, y - oy, Nx, Ny);
 Nx := Nx + ox;
 Ny := Ny + oy;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04110
ID: 04111
Category:Алгоритмы
Category:Графика
Category:Геометрия
Rotate a 3D Point around another 3D Point

const
 PIDiv180 = 0.017453292519943295769236907684886;
{ Поворот точки (x,y,z) вокруг начала координат на углы Rx, Ry, Rz }
procedure Rotate3D(Rx, Ry, Rz: Double; x, y, z: Double; var Nx, Ny, Nz: Double);
var
 TempX: Double;
 TempY: Double;
 TempZ: Double;
 SinX: Double;
 SinY: Double;
 SinZ: Double;
 CosX: Double;
 CosY: Double;
 CosZ: Double;
 XRadAng: Double;
 YRadAng: Double;
 ZRadAng: Double;
begin
 XRadAng := Rx * PIDiv180;
 YRadAng := Ry * PIDiv180;
 ZRadAng := Rz * PIDiv180;
 SinX := Sin(XRadAng);
 SinY := Sin(YRadAng);
 SinZ := Sin(ZRadAng);
 CosX := Cos(XRadAng);
 CosY := Cos(YRadAng);
 CosZ := Cos(ZRadAng);
 Tempy := y * CosY - z * SinY;
 Tempz := y * SinY + z * CosY;
 Tempx := x * CosX - Tempz * SinX;
 Nz := x * SinX + Tempz * CosX;
 Nx := Tempx * CosZ - TempY * SinZ;
 Ny := Tempx * SinZ + TempY * CosZ;
end;
{ Поворот точки (x,y,z) вокруг точки (ox,oy,oz) на углы Rx, Ry, Rz }
procedure Rotate3DAround(Rx, Ry, Rz: Double; x, y, z, ox, oy, oz: Double;
 var Nx, Ny, Nz: Double);
begin
 Rotate3D(Rx, Ry, Rz, x - ox, y - oy, z - oz, Nx, Ny, Nz);
 Nx := Nx + ox;
 Ny := Ny + oy;
 Nz := Nz + oz;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04112
Category:Алгоритмы
Category:Графика
Category:Геометрия