nyuuzyou/wikis huggingface dataset:
Можно ли обратиться к колонке или строке grid'а по заголовку?

=== Можно ли обратиться к колонке или строке grid'а по заголовку? ===
В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption). 
procedure TForm1.FormCreate(Sender: TObject);
begin
 StringGrid1.Rows[1].Strings[0] := 'This Row';
 StringGrid1.Cols[1].Strings[0] := 'This Column';
end;
function GetGridColumnByName(Grid: TStringGrid; ColName: string): integer;
var
 i: integer;
begin
 for i := 0 to Grid.ColCount - 1 do
 if Grid.Rows[0].Strings[i] = ColName then
 begin
 Result := i;
 exit;
 end;
 Result := -1;
end;
function GetGridRowByName(Grid: TStringGrid; RowName: string): integer;
var
 i: integer;
begin
 for i := 0 to Grid.RowCount - 1 do
 if Grid.Cols[0].Strings[i] = RowName then
 begin
 Result := i;
 exit;
 end;
 Result := -1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 Column: integer;
 Row: integer;
begin
 Column := GetGridColumnByName(StringGrid1, 'This Column');
 if Column = -1 then
 ShowMessage('Column not found')
 else
 ShowMessage('Column found at ' + IntToStr(Column));
 Row := GetGridRowByName(StringGrid1, 'This Row');
 if Row = -1 then
 ShowMessage('Row not found')
 else
 ShowMessage('Row found at ' + IntToStr(Row));
end;
ID: 00610
Можно ли определить интернет адрес?

unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ActiveX, SHDocVw, MSHTML_TLB, StdCtrls;
type
 TForm1 = class(TForm)
 Memo1: TMemo;
 procedure FormCreate(Sender: TObject);
 end;
var
 Form1: TForm1;
implementation
{$R *.dfm}
function GetHTMLCode(WB: IWebbrowser2; ACode: TStrings): Boolean;
var
 Range: IHTMLTxtRange;
begin
 Range := ((WB.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
 ACode.Text := ACode.Text + Range.Text;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
 ShellWindow: IShellWindows;
 WB: IWebbrowser2;
 spDisp: IDispatch;
 IDoc1: IHTMLDocument2;
 k: Integer;
begin
 ShellWindow := CoShellWindows.Create;
 for k := 0 to ShellWindow.Count do
 begin
 spDisp := ShellWindow.Item(k);
 if spDisp = nil then Continue;
 spDisp.QueryInterface(IWebBrowser2, WB);
 if WB <> nil then
 begin
 WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
 if iDoc1 <> nil then
 begin
 WB := ShellWindow.Item(k) as IWebbrowser2;
 begin
 Memo1.Lines.Add('****************************************');
 Memo1.Lines.Add(WB.LocationURL);
 Memo1.Lines.Add('****************************************');
 GetHTMLCode(WB, Memo1.Lines);
 end;
 end;
 end;
 end;
end;
end.
Author: Rouse_
Source: http://forum.sources.ru
ID: 03583
Category:Связь
Category:Web
Можно ли отключить определенный элемент в RadioGroup?

=== Можно ли отключить определенный элемент в RadioGroup? ===
В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.
procedure TForm1.Button1Click(Sender: TObject);
begin
 TRadioButton(RadioGroup1.Controls[1]).Enabled := False;
end;
ID: 01315
Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?

=== Можно ли создать форму, которая получает дополнительные параметры в методе Сreate? ===
Просто замените конструктор Create класса Вашей формы.
unit Unit2;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
 TForm2 = class(TForm)
 private
 { Private declarations }
 public
 { Public declarations }
 constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
 end;
var
 Form2: TForm2;
implementation
{$R *.DFM}
constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
begin
 Create(aOwner);
 Caption := aCaption;
end;
uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin
 Unit2.Form2 := Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
 Unit2.Form2.Show;
end;
ID: 00438
Можно ли удалять из списка TDriveComboBox диски которые отключены?

=== Можно ли удалять из списка TDriveComboBox диски которые отключены? ===
На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять из списка TDriveComboBox диски которые отключены?
В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready). Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play флоппи дисковода.
procedure TForm1.FormCreate(Sender: TObject);
var
 i: integer;
 OldErrorMode: Word;
 OldDirectory: string;
begin
 OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
 GetDir(0, OldDirectory);
 i := 0;
 while i <= DriveComboBox1.Items.Count - 1 do
 begin
{$I-}
 ChDir(DriveComboBox1.Items[i][1] + ':\');
{$I+}
 if IoResult <> 0 then
 DriveComboBox1.Items.Delete(i)
 else
 inc(i);
 end;
 ChDir(OldDirectory);
 SetErrorMode(OldErrorMode);
end;
ID: 01379
Моё CGI-приложение при обращении к нему ничего не возвращает

Вопрос: Мое CGI-приложение при обращении к нему, имеющим вид, например, http://127.0.0.1/cgi-bin/mycgi.exe ничего не возвращает. Что делать?
Установите свойство TWebAction.Default: Boolean в true для той Action из списка, которая должна по обрабатывать запросы тогда, когда это не делает ни одна из других Actions.
Source: Взято с http://delphiworld.narod.ru
ID: 03424
Category:Связь
Category:Web
Нeсколько полезных функций для работы с цветами.

{ **** UBPFD *********** by kladovka.net.ru ****
>> Работа с цветами
Нeсколько полезных функций для работы с цветами.
// Получить цвет, темнее исходного на Percent процентов
function DarkerColor(const Color: TColor; Percent: Integer): TColor;
// Получить цвет, светлее исходного на Percent процентов
function LighterColor(const Color: TColor; Percent: Integer): TColor;
// Смешать несколько цветов и получить средний
function MixColors(const Colors: array of TColor): TColor;
// Сделать цвет черно-белым
function GrayColor(Color: TColor): TColor;
Зависимости: Windows, Graphics
Автор: Gero, tov.vaskin@inbox.ru, Днепропетровск(Украина)
Copyright: Gero
Дата: 11 февраля 2004 г.
********************************************** }
function DarkerColor(const Color: TColor; Percent: Integer): TColor;
var
 R, G, B: Byte;
begin
 Result := Color;
 if Percent <= 0 then Exit;
 if Percent > 100 then Percent := 100;
 Result := ColorToRGB(Color);
 R := GetRValue(Result);
 G := GetGValue(Result);
 B := GetBValue(Result);
 R := R - R * Percent div 100;
 G := G - G * Percent div 100;
 B := B - B * Percent div 100;
 Result := RGB(R, G, B);
end;
function LighterColor(const Color: TColor; Percent: Integer): TColor;
var
 R, G, B: Byte;
begin
 Result := Color;
 if Percent <= 0 then Exit;
 if Percent > 100 then Percent := 100;
 Result := ColorToRGB(Result);
 R := GetRValue(Result);
 G := GetGValue(Result);
 B := GetBValue(Result);
 R := R + (255 - R) * Percent div 100;
 G := G + (255 - G) * Percent div 100;
 B := B + (255 - B) * Percent div 100;
 Result := RGB(R, G, B);
end;
function MixColors(const Colors: array of TColor): TColor;
var
 R, G, B: Integer;
 i: Integer;
 L: Integer;
begin
 R := 0;
 G := 0;
 B := 0;
 for i := Low(Colors) to High(Colors) do
 begin
 Result := ColorToRGB(Colors[i]);
 R := R + GetRValue(Result);
 G := G + GetGValue(Result);
 B := B + GetBValue(Result);
 end;
 L := Length(Colors);
 Result := RGB(R div L, G div L, B div L);
end;
function GrayColor(Color: TColor): TColor;
var
 Gray: Byte;
begin
 Result := ColorToRGB(Color);
 Gray := (GetRValue(Result) + GetGValue(Result) + GetBValue(Result)) div 3;
 Result := RGB(Gray, Gray, Gray);
end;
Author: Gero, tov.vaskin@inbox.ru, Днепропетровск(Украина)
ID: 03714
Category:Графика
Category:Цвета и палитры
Набор dialup соединения по умолчанию

=== Набор dialup соединения по умолчанию ===
Для w9x, me:
procedure TForm1.Button1Click(Sender: TObject);
var
 cmd, par, fil, dir: PChar;
begin
 Cmd := 'open';
 Fil := 'rasdial.exe';
 Par := PChar(edtEntry.Text + ' ' + EdtUser.Text + ' ' + EdtPass.Text);
 Dir := 'C:';
 ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
 Cmd, Par, Fil, Dir: PChar;
begin
 Cmd := 'open';
 Fil := 'rasdial.exe';
 Par := PChar(EdtEntry.Text + ' /DISCONNECT');
 Dir := 'C:';
 ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE);
end;
ID: 01469
----
uses Registry, Windows;
function DUNDialDefault(Hide: Boolean): Boolean;
var
 Reg: TRegistry;
 TempResult: Boolean;
 Name, Con: string;
 ASW: Integer;
begin
 with TRegistry.Create do
 try
 RootKey := HKEY_CURRENT_USER;
 if OpenKey('\RemoteAccess', False) then
 begin
 TempResult := True;
 Name := ReadString('Default');
 end
 else
 TempResult := False;
 finally
 Free;
 end;
 if TempResult then
 begin
 if Hide then
 ASW := SW_HIDE
 else
 ASW := SW_SHOWDEFAULT;
 Con := 'rnaui.dll,RnaDial ' + Name;
 ShellExecute(0, nil, 'rundll32.exe', PChar(Con), 'C:\windows\', ASW);
 end; {IF}
 Result := TempResult;
end;
ID: 01470
----
Для Nt, w2k, XP:
uses WinInet;
InternetAutoDial(INTERNET_AUTODIAL_FORCE_ONLINE, Handle);
 Handle - окно, из которого вызывается функция.
Author: Song
Source: Взято из http://forum.sources.ru
ID: 01471
Навигация в TWebbrowser по линкам

procedure TForm1.Button1Click(Sender: TObject);
var
 Flags, Headers, TargetFrameName, PostData: OLEVariant;
 Url, Ref: string;
 IEApp: OLEVariant;
begin
 try
 IEApp := CreateOLEObject('InternetExplorer.Application');
 except
 Exit;
 end;
 IEApp.Visible := True;
 IEApp.Top := 0;
 IEApp.Left := 0;
 IEApp.Width := Screen.Width;
 IEApp.Height := Screen.Height;
 Flags := '1';
 TargetFrameName := ;
 PostData := ;
 Url := 'http://www.dach.de/weiterempfehlen.php';
 Ref := 'http://www.dach.de/';
 // u cannot navigate to the url above without this referer
 Headers := 'Referer: ' + Ref + #10 + #13;
 IEApp.Navigate(Url, Flags, TargetFrameName, PostData, Headers);
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03465
Category:Связь
Category:WebBrowser
Над какой закладкой курсор в TabControl?

=== Над какой закладкой курсор в TabControl? ===
Получение позиции мышиного курсора для TabControl над какой закладкой находится курсор.
function Form1.ItemAtPos(TabControlHandle: HWND; X, Y: Integer) : Integer;
var
 HitTestInfo: TTCHitTestInfo;
 HitIndex: Integer;
begin
 HitTestInfo.pt.x := X;
 HitTestInfo.pt.y := Y;
 HitTestInfo.flags := 0;
 HitIndex := SendMessage(TabControlHandle, TCM_HITTEST, 0, Longint(@HitTestInfo));
 Result := HitIndex;
end;
Author: YoungHacker
Source: Взято с http://delphiworld.narod.ru
ID: 01164
ID: 01178
Надпись на часах в трее

=== Надпись на часах в трее ===
var
 hTrayClock: HWND;
 DC: HDC;
 r: TRect;
begin
 hTrayClock := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd',nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil);
 GetWindowRect(hTrayClock, r);
 DC := GetDC(0);
 //SetBkMode(DC, TRANSPARENT); // можно сделать прозрачный фон
 SetTextColor(DC, RGB($0FF, 0, 0));
 SetBkColor(DC, RGB($0FF, $0FF, 0));
 TextOut(DC, r.Left+((r.Right-r.Left) div 4), r.Top+((r.Bottom-r.Top) div 4), '>:-(', 4);
 ReleaseDC(hTrayClock, DC);
end.
При следующем обновлении часов надпись исчезнет. Так что можно делать это по таймеру.
Author: Krid
Source: Взято из http://forum.sources.ru
ID: 01765
Нажатия клавиши и звук

procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 PlaySound('wmpaud7.wav', 0, SND_NOSTOP + SND_ASYNC);
end;
procedure TForm1.Button1MouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 PlaySound(nil, 0, 0);
end;
Author: Smike
Source: http://forum.sources.ru
ID: 03620
Category:Звук
Название месяца в номер месяца

=== Название месяца --> номер месяца ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Функция преобразует текстовую строку, задающую название месяца, в номер месяца
функция преобразует текстовую строку,задающую название месяца, в номер месяца
Зависимости: ???
Автор: Сергей, nfkazak@inbox.ru, Краснодар
Copyright: VIP BANK
Дата: 11 сентября 2002 г.
***************************************************** }
function NumMonth(SMonth: string): word;
var
 i: byte;
begin
 Result := 0;
 for i := 1 to 12 do
 if AnsiUpperCase(SMonth) = Month[i] then
 Result := i
end;
Source: http://delphibase.endimus.com
ID: 00754
----
...через цикл обхода элементов глобального массива LongMonthNames:
function GetMonthNumber(Month: String): Integer;
begin
 for Result := 1 to 12 do
 if Month = LongMonthNames[Result] then
 Exit;
 Result := 0;
end;
Source: http://delphiworld.narod.ru
ID: 00759
Назначение палитры Bitmap

Если вы рисуете на TImage....
Во-первых, вам нужно использовать Image1.Picture.bitmap, а не Image.Canvas. Причина кроется в том, что Image1.Picture.Bitmap имеет палитру, в TImage нет. 
Затем палитру необходимо назначить. Вот пример:
// Устанавливаем Width и Height перед использованием
// Image1.Picture c Bitmap Canvasvar
var
 Bitmap: TBitmap;
begin
 Bitmap := TBitmap.Create;
 Bitmap.LoadfromFile({'Whatever.bmp'});
 with Image2.Picture.Bitmap do
 begin
 Width := Bitmap.Width;
 Height := Bitmap.Height;
 Palette := Bitmap.Palette;
 Canvas.Draw(0, 0, Bitmap);
 Refresh;
 end;
end;
Если вы рисуете на канве формы...
 Canvas.Draw(0, 0, Bitmap);
 SelectPalette(Form1.Canvas.Handle, Bitmap.Palette, True);
 RealizePalette(Form1.Canvas.Handle);
Source: http://delphiworld.narod.ru/
ID: 03715
ID: 03771
Category:Графика
Category:Цвета и палитры
Category:Bitmap
Назначение цвета для каждой строки

=== Назначение цвета для каждой строки ===
procedure TFormHistory.ListHistoryDrawCell(Sender: TObject; Col, Row: Integer;
 Rect: TRect; State: TGridDrawState);
var
 S: string;
 DrawRect: TRect;
 CurrentColor: TColor;
begin
 // Определяем цвет строки в зависимости типа Imcoming
 if (Sender as TStrinGgrid).Cells[COLUMN_INCOMING , Row ] = '1' then
 CurrentColor := clBlue
 else
 CurrentColor := clMaroon;
 if (Sender as TStrinGgrid).Row = Row then
 CurrentColor := clHighlightText;
 (Sender as TStrinGgrid).Canvas.font.color := CurrentColor;
 S := (Sender as TStrinGgrid).Cells[Col, Row];
 if (Col = COLUMN_MESSAGE) and (Row <> ROW_HEADER) then
 begin
 if Length(S) > 0 then
 begin
 DrawRect := Rect;
 DrawText((Sender as TStrinGgrid).Canvas.Handle, PChar(S), Length(S),
 DrawRect, dt_calcrect or dt_wordbreak or dt_left);
 if (DrawRect.Bottom - DrawRect.Top) > (Sender as TStrinGgrid).RowHeights[Row] then
 (Sender as TStrinGgrid).RowHeights[row] := (DrawRect.Bottom - DrawRect.Top)
 else
 begin
 DrawRect.Right := Rect.Right;
 (Sender as TStrinGgrid).Canvas.FillRect(DrawRect);
 DrawText((Sender as TStrinGgrid).Canvas.Handle, PChar(S),
 Length(S), DrawRect, dt_wordbreak or dt_left);
 end;
 end;
 end
 else
 if Row <> ROW_HEADER then
 (Sender as TStrinGgrid).Canvas.TextOut(Rect.Left + 3, Rect.Top + 3, S);
end;
Source: http://delphiworld.narod.ru/
ID: 01080
Найти smtp mailserver по умолчанию?

{
 Here is some code I successfully used te determine
 the DEFAULT mailaccount, which is used in
 Outlook Express, to send outgoing mail via SMTP.
}
procedure TForm1.ReadRegistryDefaults;
var
 Registry: TRegistry;
 AccountStr: string;
begin
 Registry := TRegistry.Create;
 try
 Registry.RootKey := hkey_CURRENT_USER;
 if Registry.OpenKey('software\microsoft\internet account manager', False) then
 begin
 AccountStr := Registry.ReadString('default mail account');
 Registry.CloseKey;
 if (AccountStr <> ) then
 if Registry.OpenKey('software\microsoft\internet account manager\accounts\' +
 AccountStr, False) then
 begin
 Edit_Server.Text := Registry.ReadString('SMTP Server');
 Edit_Account.Text := Registry.ReadString('SMTP Email Address');
 Registry.CloseKey;
 end;
 end;
 finally
 Registry.Free;
 end;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03408
Category:Связь
Category:Электронная почта
Найти все ссылки в TMemo

=== Найти все ссылки в TMemo ===
{ 
 For this tip you need Memo1, ListBox1, Label1, Button1. 
}
procedure TForm1.Button1Click(Sender: TObject);
var
 i, p: Integer;
 s: string;
begin
 ListBox1.Clear;
 for i := 0 to Memo1.Lines.Count - 1 do
 begin
 if Pos('http://', Memo1.Lines.Strings[i]) > 0 then
 begin
 s := ;
 { If the current line contains a "http://", read on until a space is found
 Die aktuelle Zeile wird nach der Zeichenfolge "http://" durchsucht
 und bei Erfolg ab der gefundenen Position ausgelesen, bis ein
 Leerzeichen auftritt... }
 for p := Pos('http://', Memo1.Lines.Strings[i]) to
 Length(Memo1.Lines.Strings[i]) do
 if Memo1.Lines.Strings[i][p] <> ' ' then
 s := s + Memo1.Lines.Strings[i][p]
 else
 break;
 { Remove some characters if address doesn't end with a space
 Falls die gefundene Adresse nicht mit einem Leerzeichen abschlie?t,
 werden hier noch anhangende Textzeichen entfernt... }
 while Pos(s[Length(s)], '..;!")]}?>') > 0 do
 Delete(s, Length(s), 1);
 // Add the Address to the list...
 // Gefundene Adresse in die Liste aufnehmen...
 ListBox1.Items.Add(s);
 end;
 end;
 // Show the number of Addresses in Label1
 // Die Zahl der gefundenen Adressen in Label1 anzeigen...
 if ListBox1.Items.Count > 0 then
 label1.Caption := IntToStr(ListBox1.Items.Count) +
 ' Adresse(n) gefunden.'
 else
 label1.Caption := 'Keine Adresse gefunden.';
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00998
Найти и выделить текст в TWebBrowser?

{....}
 private
 procedure SearchAndHighlightText(aText: string);
{....}
procedure TForm1.SearchAndHighlightText(aText: string);
var
 i: Integer;
begin
 for i := 0 to WebBrowser1.OleObject.Document.All.Length - 1 do
 begin
 if Pos(aText, WebBrowser1.OleObject.Document.All.Item(i).InnerText) <> 0 then
 begin
 WebBrowser1.OleObject.Document.All.Item(i).Style.Color := '#FFFF00';
 WebBrowser1.OleObject.Document.All.Item(i).ScrollIntoView(True);
 end;
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 SearchAndHighlightText('some text...');
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03462
Category:Связь
Category:WebBrowser
Найти позицию каретки

=== Найти позицию каретки ===
function GetCaretPosition(var APoint: TPoint): Boolean;
var w: HWND;
 aID, mID: DWORD;
begin
 Result:= False;
 w:= GetForegroundWindow;
 if w <> 0 then
 begin
 aID:= GetWindowThreadProcessId(w, nil);
 mID:= GetCurrentThreadid;
 if aID <> mID then
 begin
 if AttachThreadInput(mID, aID, True) then
 begin
 w:= GetFocus;
 if w <> 0 then
 begin
 Result:= GetCaretPos(APoint);
 Windows.ClientToScreen(w, APoint);
 end;
 AttachThreadInput(mID, aID, False);
 end;
 end;
 end;
end;
// Small demo: set cursor to active caret position
procedure TForm1.Timer1Timer(Sender: TObject);
var
 Pt: TPoint;
begin
 if GetCaretPosition(Pt) then
 begin
 ListBox1.Items.Add(Format('Caret position is %d %d', [Pt.x, Pt.y]));
 SetCursorPos(Pt.X, Pt.Y);
 end;
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 02340
Найти простое число

unit simple_;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 StdCtrls;
type
 TForm1 = class(TForm)
 Button1: TButton;
 Label1: TLabel;
 Edit1: TEdit;
 Label2: TLabel;
 procedure Button1Click(Sender: TObject);
 private
 { Private declarations }
 public
 { Public declarations }
 end;
var
 Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
 n: Integer; // проверяемое число
 d: Integer; // делитель
 r: Integer; // остаток от деления n на d
begin
 n := StrToInt(Edit1.Text);
 d := 2; // сначала будем делить на два
 repeat
 r := n mod d;
 if r <> 0 then // n не разделилось нацело на d
 d := d + 1;
 until r = 0; // повторять пока не найдено число на n делится без остатка
 Label2.Caption := Edit1.Text;
 if d = n then
 Label2.Caption := Label2.Caption + ' - простое число.'
 else
 Label2.Caption := Label2.Caption + ' - обычное число.';
end;
end.
Source: http://delphiworld.narod.ru/
ID: 04087
Category:Алгоритмы
Category:Математика
Найти точку пересечения прямых

// determine if 2 line cross given their end-points
function LinesCross(LineAP1, LineAP2, LineBP1, LineBP2: TPoint): Boolean;
var
 diffLA, diffLB: TPoint;
 CompareA, CompareB: Integer;
begin
 Result := False;
 diffLA := Subtract(LineAP2, LineAP1);
 diffLB := Subtract(LineBP2, LineBP1);
 CompareA := diffLA.X*LineAP1.Y - diffLA.Y*LineAP1.X;
 CompareB := diffLB.X*LineBP1.Y - diffLB.Y*LineBP1.X;
 if ( ((diffLA.X*LineBP1.Y - diffLA.Y*LineBP1.X) < CompareA) xor
 ((diffLA.X*LineBP2.Y - diffLA.Y*LineBP2.X) < CompareA) ) and
 ( ((diffLB.X*LineAP1.Y - diffLB.Y*LineAP1.X) < CompareB) xor
 ((diffLB.X*LineAP2.Y - diffLB.Y*LineAP2.X) < CompareB) ) then
 Result := True;
end;
function LineIntersect(LineAP1, LineAP2, LineBP1, LineBP2: TPoint): TPointFloat;
var
 LDetLineA, LDetLineB, LDetDivInv: Real;
 LDiffLA, LDiffLB: TPoint;
begin
 LDetLineA := LineAP1.X*LineAP2.Y - LineAP1.Y*LineAP2.X;
 LDetLineB := LineBP1.X*LineBP2.Y - LineBP1.Y*LineBP2.X;
 LDiffLA := Subtract(LineAP1, LineAP2);
 LDiffLB := Subtract(LineBP1, LineBP2);
 LDetDivInv := 1 / ((LDiffLA.X*LDiffLB.Y) - (LDiffLA.Y*LDiffLB.X));
 Result.X := ((LDetLineA*LDiffLB.X) - (LDiffLA.X*LDetLineB)) * LDetDivInv;
 Result.Y := ((LDetLineA*LDiffLB.Y) - (LDiffLA.Y*LDetLineB)) * LDetDivInv;
end;
function Subtract(AVec1, AVec2: TPoint): TPoint;
begin
 Result.X := AVec1.X - AVec2.X;
 Result.Y := AVec1.Y - AVec2.Y;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04116
Category:Алгоритмы
Category:Графика
Category:Геометрия
Найти центр треугольника

== Координаты центра окружности, описанной вокруг 2D треугольника ==
procedure Circumcenter(x1, y1, x2, y2, x3, y3: Double; var Px, Py: Double);
var
 A, C, B, D, E, F, G: Double;
begin
 A := x2 - x1;
 B := y2 - y1;
 C := x3 - x1;
 D := y3 - y1;
 E := A * (x1 + x2) + B * (y1 + y3);
 F := C * (x1 + x2) + D * (y1 + y3);
 G := 2.0 * (A * (y3 - y2) - B * (x3 - x2));
 if G = 0 then
 Exit;
 Px := (D * E - B * F) / G;
 Py := (A * F - C * E) / G;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04113
----
== Координаты центра окружности вписанной в 2D треугольник ==
procedure Incenter(x1, y1, x2, y2, x3, y3: Double; var Px, Py: Double);
var
 Perim: Double;
 Side12: Double;
 Side23: Double;
 Side31: Double;
begin
 Side12 := Distance(x1, y1, x2, y2);
 Side23 := Distance(x2, y2, x3, y3);
 Side31 := Distance(x3, y3, x1, y1);
 { using Heron's S=UR }
 Perim := 1 / (Side12 + Side23 + Side31);
 Px := (Side23 * x1 + Side31 * x2 + Side12 * x3) * Perim;
 Py := (Side23 * y1 + Side31 * y2 + Side12 * y3) * Perim;
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04114
Category:Алгоритмы
Category:Графика
Category:Геометрия