Статьи по Delphi (034)…
| Цветной ScrollBar. |
Антон Григорьев
В Windows предусмотрено сообщение WM_CtlColorScrollBar, которое посылается окну, содержащему элементы управления ScrollBar (полосы прокрутки). В ответ на это сообщение окно должно вернуть системе кисть, которой надо закрасить полосу прокрутки. С помощью WM_CtlColorScrollBar можно получать разноцветные полосы прокрутки, что иногда бывает достаточно красиво.
В Delphi форма при получении этого сообщения посылает соответствующему компоненту типа TScrollBar сообщение CN_CtlColorScrollBar, перепоручая обработку ему. И тут мы сталкиваемся с явным глюком VCL: это сообщение передаётся в стандартную оконную процедуру, хотя сообщение само по себе нестандартное, и стандартная процедура заведомо не сможет его обработать. Из-за этого TScrollBar не может изменять свой цвет, хотя львиная доля работы, необходимой для этого, делается в VCL. Чтобы исправить это, достаточно передать обработку CN_CtlColorScrollBar в метод DefaultHandler вместо DefWndProc. Ещё надо перенести в раздел published свойство Color, чтобы получить возможность управлять цветом полосы прокрутки.
Но, несмотря на то, что в VCL здесь явная ошибка, не исправленная, кстати, даже в седьмой версии Delphi, править исходный код StdCtrls всё же не стоит. Вместо этого лучше написать свой компонент, который доделает то, что не доделано в стандартном TScrollBar'е. Код этого компонента будет выглядеть так:
Code: Type. TColorScrollBar=class(TScrollBar). Private. Procedure CNCtlColorScrollBar(var Msg:TMessage);message CN_CtlColorScrollBar; Published. Property Color; End; Procedure TColorScrollBar.CNCtlColorScrollBar(var Msg:TMessage); Begin. DefaultHandler(Msg). End;
| Цветные строки для TListView. |
Code: Procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView; Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean); Begin. With ListView1.Canvas.Brush do. Begin. Case Item.Index of. 0: Color := clYellow; 1: Color := clGreen; 2: Color := clRed; End; End; End;
©Drkb::01152.
Взято с сайта: http://www.swissdelphicenter.ch.
| Цвет неактивной ячейки StringGrid. |
Автор: Neil J. Rubenking.
Указание языка помещенного в clipboard текста.
| Указание языка помещенного в clipboard текста |
Столкнулся с проблемой вставки в Clipboard русского текста в Win2K, WinXP. Залез в DRKB.. Ну да, там вариант предложен довольно смешной (создать TRichEdit, вставить в него clipboard, весь текст пометить русским, и вернуть в clipboard)... Всё бы ничего, но если у меня программа без форм, да и без окон вообще, то TRichEdit не создаётся ('Control has no parent window') . Почитал хелп, посмотрел, что именно Вынь сует в буфер на разных языках, и нашёл простой и красивый способ. Имхо, ему там и место - в разделе "Буфер обмена". Как вставить русский текст в буфер обмена Windows 2000, Windows XP Для указания языка текста в clipboard используется специальный формат CF_LOCALE. Данные в этом формате - это LocaleID: word. При вставке текста в формате CF_TEXT, или CF_OEMTEXT, нужно просто добавить LocaleID в формате CF_LOCALE, после чего Windows сможет правильно преобразовать имеющийся текст в недостающие форматы (например в CF_UNICODETEXT), да и просто будет корректно вставлен в самом CF_TEXT.
Code: Procedure CopyDataToClipboard(fmt: word; s: string); Var. Hg: THandle; P: PChar; Begin. Hg:=GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Length(S)+1); P:=GlobalLock(hg); StrPCopy(P, s); GlobalUnlock(hg); Clipboard.Open; SetClipboardData(fmt, hg); // fmt = CF_UNICODETEXT | CF_OEMTEXT | CF_TEXT | CF_LOCALE. Clipboard.Close; GlobalFree(hg); End; Procedure CopyStringToClipboard(const s: string); Var Locale: word; Begin. //Set CF_TEXT & CF_LOCALE. CopyDataToClipboard(CF_TEXT, s); Locale := GetSystemDefaultLangID; //Get it as you please. even hard-coded ;) $0419 = LANG_RUSSIAN (f.e.). CopyDataToClipboard(CF_LOCALE, Chr(Lo(Locale))+Chr(Hi(Locale))); End;
Взято из http://forum.sources.ru.
Автор: Mechanic.
©Drkb::01899.
| Указатель на вариантный тип |
I just ran across this in some of my old code and thought I''d share it with you:
| Указатель на функцию |
Это то, что я нашел при создании простой машины состояний:
Целочисленное деление.
| Целочисленное деление |
Code: Select Cast((@dividend-(@dividend % @divisor))/@divisor as bigint).
©Drkb::02817.
Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).
| Центр вписанной в треугольник окружности |
Code: {**** UBPFD *********** by kladovka.net.ru **** >> Центр вписанной в треугольник окружности. P1, P2, P3 - вершины треугольника. Зависимости: Windows. Автор: Fenik, fenik@nm.ru, Новоуральск. Copyright: Николай Федоровских. Дата: 29 сентября 2004 г. ********************************************** } Function CenterCircleInTriang(const P1, P2, P3: TPoint): TPoint; Function LineLength(P1, P2: TPoint): Double; Begin. Result := Sqrt(Sqr(P1.X - P2.X) + Sqr(P1.Y - P2.Y)); End; Var a, b, c, Perim: Double; Begin. A := LineLength(P1, P2); B := LineLength(P2, P3); C := LineLength(P3, P1); Perim := 1 / (a + b + c); Result := Point(Round((b * P1.x + c * P2.x + a * P3.x) * Perim), Round((b * P1.y + c * P2.y + a * P3.y) * Perim)); End; Пример использования: Function Distance(const P, P1, P2: TPoint): Integer; { Расстояние от точки P до прямой P1-P2 }. Begin. Result := Abs(Round( ((P1.Y - P2.Y) * P.X + (P2.X - P1.X) * P.Y + (P1.X * P2.Y - P2.X * P1.Y)) / Sqrt(Sqr(P1.X - P2.X) + Sqr(P2.Y - P1.Y)))); End; Procedure TForm1.Button1Click(Sender: TObject); Var P1, P2, P3, C: TPoint; L: Integer; Begin. P1 := Point(60, 160); P2 := Point(250, 110); P3 := Point(365, 350); C := CenterCircleInTriang(P1, P2, P3); L := Distance(C, P1, P2); With Canvas do begin. Brush.Color := clWhite; Polygon([P1, P2, P3]); Brush.Color := clRed; Ellipse(C.X - L, C.Y - L, C.X + L, C.Y + L); End; End;
| Фильтрация, регрессия, работа с массивом и серией |
Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Фильтрация, регрессия, работа с массивом и серией. Модуль предназначен для выполнения процедур: - фильтрации. - регрессии. - операций с массивами. - операций с сериями. Зависимости: Math, TeEngine, Graphics, SysUtils, Dialogs. Автор: lookin, lookin@mail.ru, Екатеринбург. Copyright: lookin. Дата: 30 апреля 2002 г. ***************************************************** } Unit FilterRegressionArraySeries; Interface. Uses Math, TeEngine, Graphics, SysUtils, Dialogs; Type. TIntegerArray = array of integer; Type. TExIntegerArray = array of TIntegerArray; Type. TDoubleArray = array of double; Type. TExDoubleArray = array of TDoubleArray; Type. TStringArray = array of string; Type. TExStringArray = array of TStringArray; Procedure ArrayExpanding(var ValueArray: TDoubleArray; ExpandCoef: integer); Procedure ArrayLengthening(var ValueArray: TDoubleArray; SplitValue: integer); Procedure ArrayShortening(var ValueArray: TDoubleArray; SplitValue: integer); Procedure CubicSplineSmoothing(var ValueArray: TDoubleArray; Dsc: double; Coef: integer); Procedure SevenPointNonLinearSmoothing(var ValueArray: TDoubleArray; Dsc: double; Coef: integer); Procedure FourierAnalysis(var ValueArray: TDoubleArray; NumGarmonics: integer); Procedure DoArraySmoothing(var ValueArray: TDoubleArray; FilterType: integer; Dsc: double; SplitCoef, ExpandCoef: integer; CycledFilter: boolean); Procedure LinearRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; Var MainCoef, FreeCoef: double; SeriesColor: TColor; Var Hint: string); Procedure HyperbolicRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; Var MainCoef, FreeCoef: double; SeriesColor: TColor; var Hint: string); Procedure PowerRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; Var MainCoef, FreeCoef: double; SeriesColor: TColor; Var Hint: string); Procedure PolynomialRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; PolyDegree: integer; var ArrayCoefs: TDoubleArray; SeriesColor: TColor; var Hint: string); Procedure ExponentRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; Var MainCoef, FreeCoef: double; SeriesColor: TColor; Var Hint: string; Warning: boolean); Procedure ExponentialRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; Var MainCoef, FreeCoef: double; SeriesColor: TColor; Var Hint: string; Warning: boolean); Procedure ExpPowerRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; Var MainCoef, FreeCoef: double; SeriesColor: TColor; Var Hint: string; Warning: boolean); Procedure CheckArrayBounds(var CArray: TDoubleArray; var FromPoint, ToPoint: Integer); Procedure CheckSeriesBounds(CSeries: TChartSeries; var FromPoint, ToPoint: Integer); Procedure ArrayFromArray(var SourceArray, DestArray: TDoubleArray; FromPoint, ToPoint, Discrete: integer; Derivative: boolean); Procedure ArrayFromSeries(var ValueArray: TDoubleArray; DataSeries: TChartSeries; FromPoint, ToPoint, Discrete: integer; Derivative: boolean); Procedure SeriesFromArray(var ValueArray: TDoubleArray; DataSeries: TChartSeries; FromPoint, ToPoint, Discrete: integer; Derivative: boolean); Function DerivFromArray(var SourceArray: TDoubleArray; FromPoint, ToPoint, Discrete: integer; Extremum: string; Var Position: integer): double; Function DerivFromSeries(DataSeries: TChartSeries; FromPoint, ToPoint, Discrete: integer; Extremum: string; Var Position: integer): double; Function ValueFromSeries(DataSeries: TChartSeries; FromPoint, ToPoint: integer; Extremum: string; var Position: integer): double; Function ValueFromArray(var SourceArray: TDoubleArray; FromPoint, ToPoint: Integer; Extremum: string; var Position: integer): double; Function CalculateAreaOfArray(var SourceArray: TDoubleArray; FromPoint, ToPoint, Method: integer; BindToZero: boolean): double; Function CalculateAreaOfSeries(DataSeries: TChartSeries; FromPoint, ToPoint, Method: integer; BindToZero: boolean): double; Procedure LinearTrendExclusion(var ValueArray: TDoubleArray); Procedure ColorizeSeries(DataSeries: TChartSeries; NewColor: TColor); Procedure SetXInterval(DataSeries: TChartSeries; XInterval: double); Procedure SetSeriesAxis(DataSeries: TChartSeries; NewAxis: TVertAxis); Var. Rv, rsmooth, smootha: TDoubleArray; Implementation. //Нелинейный фильтр по 7 точкам. Procedure SevenPointNonLinearSmoothing(var ValueArray: TDoubleArray; Dsc: double; Coef: integer); Var. J, k, i: integer; Resv: array of array of double; Begin. If (Coef = 0) or (Coef = 1) then. Exit; SetLength(resv, Coef, (Length(ValueArray) div Coef)); For j := 0 to Coef - 1 do. For i := 0 to Length(resv[0]) - 1 do. Resv[j][i] := ValueArray[i * Coef + j]; For k := 0 to Coef - 1 do. For j := 0 to Length(resv[0]) - 1 do. Begin. If j = 0 then. Resv[k][j] := (39 * ValueArray[j * Coef + k] + 8 * ValueArray[(j + 1) * Coef + k] - 4 * (ValueArray[(j + 2) * Coef + K] + ValueArray[(j + 3) * Coef + k] - ValueArray[(j + 4) * Coef + k]) + ValueArray[(j + 5) * Coef + k] - 2 * ValueArray[(j + 6) * Coef + k]) / 42; If j = 1 then. Resv[k][j] := (8 * ValueArray[j * Coef + k] + 19 * ValueArray[(j + 1) * Coef + k] + 16 * ValueArray[(j + 2) * Coef + K] + 6 * ValueArray[(j + 3) * Coef + k] - 4 * ValueArray[(j + 4) * Coef + k]. - 7 * ValueArray[(j + 5) * Coef + k] + 4 * ValueArray[(j + 6) * Coef + K]) / 42; If j = 2 then. Resv[k][j] := (-4 * ValueArray[j * Coef + k] + 16 * ValueArray[(j + 1) * Coef + k] + 19 * ValueArray[(j + 2) * Coef + K] + 12 * ValueArray[(j + 3) * Coef + k] + 2 * ValueArray[(j + 4) * Coef + K] - 4 * ValueArray[(j + 5) * Coef + k] + ValueArray[(j + 6) * Coef + k]) / 42; If (j > 2) and (j < Length(resv[0]) - 3) then. Resv[k][j] := (7 * ValueArray[j * Coef + k] + 6 * (ValueArray[(j - 1) * Coef + k] + ValueArray[(j + 1) * Coef + k]) + 3 * (ValueArray[(j - 2) * Coef + k]. + ValueArray[(j + 2) * Coef + k]) - 2 * (ValueArray[(j - 3) * Coef + k]. + ValueArray[(j + 3) * Coef + k])) / 21; If j = Length(resv[0]) - 3 then. Resv[k][j] := (-4 * ValueArray[j * Coef + k] + 16 * ValueArray[(j - 1) * Coef + k] + 19 * ValueArray[(j - 2) * Coef + K] + 12 * ValueArray[(j - 3) * Coef + k] + 2 * ValueArray[(j - 4) * Coef + K] - 4 * ValueArray[(j - 5) * Coef + k] + ValueArray[(j - 6) * Coef + k]) / 42; If j = Length(resv[0]) - 2 then. Resv[k][j] := (8 * ValueArray[j * Coef + k] + 19 * ValueArray[(j - 1) * Coef + k] + 16 * ValueArray[(j - 2) * Coef + K] + 6 * ValueArray[(j - 3) * Coef + k] - 4 * ValueArray[(j - 4) * Coef + k]. - 7 * ValueArray[(j - 5) * Coef + k] + 4 * ValueArray[(j - 6) * Coef + K]) / 42; If j = Length(resv[0]) - 1 then. Resv[k][j] := (39 * ValueArray[j * Coef + k] + 8 * ValueArray[(j - 1) * Coef + k] - 4 * ValueArray[(j - 2) * Coef + k]. - 4 * ValueArray[(j - 3) * Coef + k] - 4 * ValueArray[(j - 4) * Coef + k]. + ValueArray[(j - 5) * Coef + k] - 2 * ValueArray[(j - 6) * Coef + k]) / 42; End; For j := Coef to Length(resv[0]) - Coef do. For k := 0 to Coef - 1 do. ValueArray[j * Coef + k] := resv[k][j]; End; //Фильтр с кубическими сплайнами. Procedure CubicSplineSmoothing(var ValueArray: TDoubleArray; Dsc: double; Coef: integer); Var. J, k, i, N: integer; Vresv, resv: array of array of double; Maxv: array of double; Av, h, mi, mj, v1, v2: double; Begin. If (Coef = 0) or (Coef = 1) then. Exit; N := Length(ValueArray); SetLength(resv, Coef, N); H := Coef * Dsc; For k := 0 to Coef - 1 do. For j := 0 to (N div Coef) - 2 do. Begin. If j = 0 then. Begin. Mi := (4 * ValueArray[(j + 1) * Coef + k] - ValueArray[(j + 2) * Coef + k] - 3 * ValueArray[j * Coef + k]) / 2; Mj := (ValueArray[(j + 2) * Coef + k] - ValueArray[j * Coef + k]) / 2; End; If j = (N div Coef) - 2 then. Begin. Mi := (ValueArray[(j + 1) * Coef + k] - ValueArray[(j - 1) * Coef + k]). / 2; Mj := (3 * ValueArray[(j + 1) * Coef + k] + ValueArray[(j - 1) * Coef + K] - 4 * ValueArray[j * Coef + k]) / 2; End; If (j > 0) and (j < ((N div Coef) - 2)) then. Begin. Mi := (ValueArray[(j + 1) * Coef + k] - ValueArray[(j - 1) * Coef + k]). / 2; Mj := (ValueArray[(j + 2) * Coef + k] - ValueArray[j * Coef + k]) / 2; End; For i := j * Coef to (j + 1) * Coef do. Begin. V1 := ((j + 1) * Coef + k) * Dsc - (i + k) * Dsc; V2 := (i + k) * Dsc - (j * Coef + k) * Dsc; Resv[k][i + k] := (Sqr(v1) * (2 * v2 + h) * ValueArray[j * Coef + k] + Sqr(v2) * (2 * v1 + h) * ValueArray[(j + 1) * Coef + k] + (Sqr(v1) * v2 * mi + Sqr(v2) * (-v1) * mj) / 2) / h / h / h; End; End; For j := Coef to N - 1 - Coef do. Begin. Av := 0; For k := 0 to Coef - 1 do. Av := av + resv[k][j]; Av := av / Coef; ValueArray[j] := av; End; End; //Гармонический синтез Фурье. Procedure FourierAnalysis(var ValueArray: TDoubleArray; NumGarmonics: integer); Var. I, j, N: integer; Yn, ap, bp: double; AFCoef, BFCoef: TDoubleArray; Begin. N := Length(ValueArray); SetLength(AFCoef, NumGarmonics); SetLength(BFCoef, NumGarmonics); AFCoef[0] := Sum(ValueArray) / N; BFCoef[0] := 0; For i := 1 to NumGarmonics - 1 do. Begin. AFCoef[i] := 0; BFCoef[i] := 0; For j := 0 to N - 1 do. Begin. AFCoef[i] := AFCoef[i] + ValueArray[j] * cos(Pi * i * j * 2 / N); BFCoef[i] := BFCoef[i] + ValueArray[j] * sin(Pi * i * j * 2 / N); End; AFCoef[i] := AFCoef[i] * 2 / N; BFCoef[i] := BFCoef[i] * 2 / N; End; For j := 0 to N - 1 do. Begin. Yn := 0; Ap := 0; Bp := 0; For i := 1 to NumGarmonics - 1 do. Begin. Ap := ap + AFCoef[i] * cos(2 * Pi * i * (j / N)); Bp := bp + BFCoef[i] * sin(2 * Pi * i * (j / N)); End; Yn := AFCoef[0] + ap + bp; ValueArray[j] := yn; End; End; //Общая процедура вызова нужного фильтра. Procedure DoArraySmoothing(var ValueArray: TDoubleArray; FilterType: integer; Dsc: double; SplitCoef, ExpandCoef: integer; CycledFilter: boolean); Var. J: integer; Begin. SmoothA := nil; Rsmooth := ValueArray; ArrayExpanding(rsmooth, ExpandCoef); ArrayLengthening(smoothA, SplitCoef); If FilterType = 1 then. If CycledFilter then. For j := 2 to SplitCoef do. SevenPointNonLinearSmoothing(smoothA, Dsc, j). Else. SevenPointNonLinearSmoothing(smoothA, Dsc, SplitCoef); If FilterType = 2 then. CubicSplineSmoothing(smoothA, Dsc, SplitCoef); ArrayShortening(smoothA, SplitCoef); ValueArray := smoothA; End; //Расширение массива заданным числом точек справа и слева. Procedure ArrayLengthening(var ValueArray: TDoubleArray; SplitValue: integer); Var. Sv, N, i: integer; Bv, ev: double; Begin. N := Length(ValueArray); Sv := 10 * SplitValue; Bv := 0; Ev := 0; For i := 0 to 9 do. Bv := bv + ValueArray[i]; Bv := bv / 10; For i := N - 1 downto N - 10 do. Ev := ev + ValueArray[i]; Ev := ev / 10; SetLength(ValueArray, N + sv); For i := N - 1 downto 0 do. ValueArray[i + trunc(sv / 2)] := ValueArray[i]; For i := trunc(sv / 2) - 1 downto 0 do. ValueArray[i] := bv; For i := N + trunc(sv / 2) to N + sv - 1 do. ValueArray[i] := ev; End; //Сокращение массива заданным числом точек справа и слева. Procedure ArrayShortening(var ValueArray: TDoubleArray; SplitValue: integer); Var. Sv, N, i: integer; Begin. N := Length(ValueArray); Sv := 10 * SplitValue; For i := 0 to N - sv - 1 do. ValueArray[i] := ValueArray[i + trunc(sv / 2)]; SetLength(ValueArray, N - sv); End; //Расширение массива заданным числом точек между 2-мя соседними. Procedure ArrayExpanding(var ValueArray: TDoubleArray; ExpandCoef: integer); Var. I, k, N, sub: integer; Diap: double; Begin. N := Length(ValueArray); Sub := ExpandCoef - 1; SetLength(smoothA, N * ExpandCoef - sub); For i := 0 to N - 1 do. Begin. SmoothA[i * ExpandCoef] := ValueArray[i]; If i <> 0 then. Begin. Diap := (smoothA[i * ExpandCoef] - smoothA[(i - 1) * ExpandCoef]); For k := 0 to ExpandCoef - 1 do. SmoothA[(i - 1) * ExpandCoef + k] := SmoothA[(i - 1) * ExpandCoef] + diap * (k / ExpandCoef); End; End; End; //Линейная регрессия. Procedure LinearRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double; SeriesColor: TColor; var Hint: string); Var. B0, b1, xsum, ysum, pxy, xsqua: double; Y, x: array of double; I, N: integer; S: string; Begin. If ValueArray <> nil then. N := Length(ValueArray). Else. N := SourceSeries.XValues.Count; Pxy := 0; Xsqua := 0; SetLength(x, N); SetLength(y, N); For i := 0 to N - 1 do. Begin. If ValueArray <> nil then. Begin. Y[i] := ValueArray[i]; X[i] := ArgumentArray[i]; End. Else. Begin. Y[i] := SourceSeries.YValues.Value[i]; X[i] := SourceSeries.XValues.Value[i]; End; Pxy := pxy + x[i] * y[i]; Xsqua := xsqua + x[i] * x[i]; End; Xsum := Sum(x); Ysum := Sum(y); B1 := (xsum * ysum - N * pxy) / (xsum * xsum - N * xsqua); B0 := (ysum - b1 * xsum) / N; MainCoef := b1; FreeCoef := b0; If DestSeries <> nil then. For i := 0 to N - 1 do. If ValueArray <> nil then. DestSeries.AddXY(ArgumentArray[i], B1 * ArgumentArray[i] + b0, '', SeriesColor). Else. DestSeries.AddXY(SourceSeries.XValues.Value[i], B1 * SourceSeries.XValues.Value[i] + b0, '', SeriesColor); If b0 < 0 then. S := '' Else. S := '+ '; Hint := Format('%0.3f', [b1]) + '*X ' + s + Format('%0.3f', [b0]); X := nil; Y := nil; End; //Гиперболическая регрессия. Procedure HyperbolicRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double; SeriesColor: TColor; var Hint: string); Var. B0, b1, ax, ysum, axsqua, dxy: double; Y, x: array of double; I, N: integer; S: string; Begin. If ValueArray <> nil then. N := Length(ValueArray). Else. N := SourceSeries.XValues.Count; Axsqua := 0; Ax := 0; Dxy := 0; SetLength(x, N); SetLength(y, N); For i := 0 to N - 1 do. Begin. If ValueArray <> nil then. Begin. Y[i] := ValueArray[i]; X[i] := ArgumentArray[i]; End. Else. Begin. Y[i] := SourceSeries.YValues.Value[i]; X[i] := SourceSeries.XValues.Value[i]; End; If x[i] = 0 then. Begin. MessageDlg('Hyperbolic regression inapplicable...', MtWarning, [mbOk], 0); Hint := 'No equation'; MainCoef := 0; FreeCoef := 0; Exit; End; Dxy := dxy + y[i] / x[i]; Ax := ax + 1 / x[i]; Axsqua := axsqua + 1 / (x[i] * x[i]); End; Ysum := Sum(y); B1 := (dxy - (ysum * ax) / N) / (axsqua - (ax * ax) / N); B0 := (ysum - b1 * ax) / N; MainCoef := b1; FreeCoef := b0; If DestSeries <> nil then. For i := 0 to N - 1 do. If ValueArray <> nil then. DestSeries.AddXY(ArgumentArray[i], B1 / ArgumentArray[i] + b0, '', SeriesColor). Else. DestSeries.AddXY(SourceSeries.XValues.Value[i], B1 / SourceSeries.XValues.Value[i] + b0, '', SeriesColor); If b0 < 0 then. S := '' Else. S := '+ '; Hint := Format('%0.3f', [b1]) + '/X ' + s + Format('%0.3f', [b0]); X := nil; Y := nil; End; //Степенная регрессия. Procedure PowerRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double; SeriesColor: TColor; var Hint: string); Var. B0, b1, lnx, lny, xlnsqua, plnxy: double; Y, x: array of double; I, N: integer; Begin. If ValueArray <> nil then. N := Length(ValueArray). Else. N := SourceSeries.XValues.Count; Lnx := 0; Lny := 0; Xlnsqua := 0; Plnxy := 0; SetLength(x, N); SetLength(y, N); For i := 0 to N - 1 do. Begin. If ValueArray <> nil then. Begin. Y[i] := ValueArray[i]; X[i] := ArgumentArray[i]; End. Else. Begin. Y[i] := SourceSeries.YValues.Value[i]; X[i] := SourceSeries.XValues.Value[i]; End; If (x[i] <= 0) or (y[i] <= 0) then. Begin. MessageDlg('Power regression inapplicable...', mtWarning, [mbOk], 0); Hint := 'No equation'; MainCoef := 0; FreeCoef := 0; Exit; End; Lnx := lnx + ln(x[i]); Lny := lny + ln(y[i]); Plnxy := plnxy + ln(x[i]) * ln(y[i]); Xlnsqua := xlnsqua + ln(x[i]) * ln(x[i]); End; B1 := (lnx * lny - N * plnxy) / (lnx * lnx - N * xlnsqua); B0 := exp((lny - b1 * lnx) / N); MainCoef := b1; FreeCoef := b0; If DestSeries <> nil then. For i := 0 to N - 1 do. If ValueArray <> nil then. DestSeries.AddXY(ArgumentArray[i], Power(ArgumentArray[i], b1) * b0, '', SeriesColor). Else. DestSeries.AddXY(SourceSeries.XValues.Value[i], Power(SourceSeries.XValues.Value[i], b1) * b0, '', SeriesColor); Hint := Format('%0.3f', [b0]) + '*X^' + Format('%0.3f', [b1]); X := nil; Y := nil; End; //Полиномиальная регрессия. Procedure PolynomialRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; PolyDegree: integer; Var ArrayCoefs: TDoubleArray; SeriesColor: TColor; var Hint: string); Var. Bcoef, dcoef: TDoubleArray; Ccoef: array of TDoubleArray; I, j, k, N: integer; Polynom: double; Begin. If ValueArray <> nil then. N := Length(ValueArray). Else. N := SourceSeries.XValues.Count; Hint := ''; ArrayCoefs := nil; SetLength(ccoef, PolyDegree + 1); For i := 0 to Length(ccoef) - 1 do. SetLength(ccoef[i], PolyDegree + 1); SetLength(dcoef, PolyDegree + 1); SetLength(bcoef, PolyDegree + 1); For i := 0 to Length(dcoef) - 1 do. Begin. Dcoef[i] := 0; For j := 0 to N - 1 do. Begin. If ValueArray <> nil then. Dcoef[i] := dcoef[i] + Power(ArgumentArray[j], i) * ValueArray[j]. Else. Dcoef[i] := dcoef[i] + Power(SourceSeries.XValues.Value[j], i) * SourceSeries.YValues.Value[j]; End; For j := 0 to Length(ccoef) - 1 do. Begin. Ccoef[i][j] := 0; For k := 0 to N - 1 do. Begin. If ValueArray <> nil then. Ccoef[i][j] := Ccoef[i][j] + Power(ArgumentArray[k], i + j). Else. Ccoef[i][j] := ccoef[i][j] + Power(SourceSeries.XValues.Value[k], i + J); End; End; End; For i := 0 to Length(ccoef) - 2 do. For j := i + 1 to Length(ccoef) - 1 do. Begin. Ccoef[j][i] := -ccoef[j][i] / ccoef[i][i]; Dcoef[j] := dcoef[j] + ccoef[j][i] * dcoef[i]; For k := i + 1 to Length(ccoef) - 1 do. Ccoef[j][k] := ccoef[j][k] + ccoef[j][i] * ccoef[i][k]; End; Bcoef[Length(bcoef) - 1] := dcoef[Length(dcoef) - 1] / Ccoef[Length(bcoef) - 1][Length(bcoef) - 1]; For i := Length(ccoef) - 2 downto 0 do. Begin. For j := i + 1 to Length(ccoef) - 1 do. Bcoef[i] := bcoef[i] + bcoef[j] * ccoef[i][j]; Bcoef[i] := (dcoef[i] - bcoef[i]) / ccoef[i][i]; End; SetLength(ArrayCoefs, Length(bcoef)); For i := 0 to Length(bcoef) - 1 do. ArrayCoefs[i] := bcoef[i]; If DestSeries <> nil then. For i := 0 to N - 1 do. Begin. Polynom := 0; If ValueArray <> nil then. Begin. For j := 0 to PolyDegree do. Polynom := polynom + bcoef[j] * Power(ArgumentArray[i], j); DestSeries.AddXY(ArgumentArray[i], polynom, '', SeriesColor); End. Else. Begin. For j := 0 to PolyDegree do. Polynom := polynom + Bcoef[j] * Power(SourceSeries.XValues.Value[i], j); DestSeries.AddXY(SourceSeries.XValues.Value[i], Polynom, '', SeriesColor); End; End; For j := PolyDegree downto 0 do. Hint := Hint + Format('%0.3f', [bcoef[j]]) + '*X^' + IntToStr(j); Dcoef := nil; Bcoef := nil; Ccoef := nil; End; //Показательная регрессия. Procedure ExponentRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double; SeriesColor: TColor; var Hint: string; Warning: boolean); Var. I, N: integer; X, y: array of double; Lgy, xsum, xsqua, a, b, lga, xlgy, lgb: double; Begin. If ValueArray <> nil then. N := Length(ValueArray). Else. N := SourceSeries.XValues.Count; Lgy := 0; Xsqua := 0; Xlgy := 0; SetLength(x, N); SetLength(y, N); For i := 0 to N - 1 do. Begin. If ValueArray <> nil then. Begin. Y[i] := ValueArray[i]; X[i] := ArgumentArray[i]; End. Else. Begin. Y[i] := SourceSeries.YValues.Value[i]; X[i] := SourceSeries.XValues.Value[i]; End; If y[i] <= 0 then. Begin. If Warning then. MessageDlg('Exponent regression inapplicable', MtWarning, [mbOk], 0); Hint := 'No equation'; MainCoef := 0; FreeCoef := 0; Exit; End; Lgy := lgy + Log10(y[i]); Xsqua := xsqua + x[i] * x[i]; Xlgy := xlgy + x[i] * Log10(y[i]); End; Xsum := Sum(x); Lgb := (xlgy - (lgy * xsum) / N) / (xsqua - (xsum * xsum) / N); Lga := (lgy - lgb * xsum) / N; B := Power(10, lgb); A := Power(10, lga); MainCoef := b; FreeCoef := a; If DestSeries <> nil then. For i := 0 to N - 1 do. If ValueArray <> nil then. DestSeries.AddXY(ArgumentArray[i], A * Power(b, ArgumentArray[i]), '', SeriesColor). Else. DestSeries.AddXY(SourceSeries.XValues.Value[i], A * Power(b, SourceSeries.XValues.Value[i]), '', SeriesColor); Hint := 'Exponent regression equation: Y = ' + Format('%0.5f', [a]) + ' * (' + Format('%0.5f', [b]) + ' ^ X)'; X := nil; Y := nil; End; //Экспоненциальная регрессия. Procedure ExponentialRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double; SeriesColor: TColor; var Hint: string; Warning: boolean); Var. I, N: integer; X, y: array of double; Lny, xsum, xsqua, xlny, b0, b1: double; Begin. MainCoef := 0; FreeCoef := 0; If ValueArray <> nil then. N := Length(ValueArray). Else. N := SourceSeries.XValues.Count; Lny := 0; Xsqua := 0; Xlny := 0; SetLength(x, N); SetLength(y, N); For i := 0 to N - 1 do. Begin. If ValueArray <> nil then. Begin. Y[i] := ValueArray[i]; X[i] := ArgumentArray[i]; End. Else. Begin. Y[i] := SourceSeries.YValues.Value[i]; X[i] := SourceSeries.XValues.Value[i]; End; If y[i] <= 0 then. Begin. If Warning then. MessageDlg('Exponential regression inapplicable', MtWarning, [mbOk], 0); Hint := 'No equation'; MainCoef := 0; FreeCoef := 0; Exit; End; Lny := lny + Ln(y[i]); Xsqua := xsqua + x[i] * x[i]; Xlny := xlny + x[i] * Ln(y[i]); End; Xsum := Sum(x); B1 := (xsum * lny - N * xlny) / (xsum * xsum - N * xsqua); B0 := exp((lny - b1 * xsum) / N); MainCoef := b1; FreeCoef := b0; If DestSeries <> nil then. For i := 0 to N - 1 do. If ValueArray <> nil then. DestSeries.AddXY(ArgumentArray[i], B0 * Exp(b1 * ArgumentArray[i]), '', SeriesColor). Else. DestSeries.AddXY(SourceSeries.XValues.Value[i], B0 * Exp(b1 * SourceSeries.XValues.Value[i]), '', SeriesColor); Hint := 'Exponential regression equation: Y = ' + Format('%0.5f', [b0]) + ' * exp(' + Format('%0.5f', [b1]) + ' * X)'; X := nil; Y := nil; End; //Степенно-экспоненциальная регрессия. Procedure ExpPowerRegression(ValueArray, ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; var MainCoef, FreeCoef: double; SeriesColor: TColor; var Hint: string; Warning: boolean); Var. I, N: integer; X, y: array of double; Matr: array[0..3] of double; Lny, xsum, xsqua, xlny, b0, b1: double; Begin. MainCoef := 0; FreeCoef := 0; If ValueArray <> nil then. N := Length(ValueArray). Else. N := SourceSeries.XValues.Count; Lny := 0; Xsqua := 0; Xlny := 0; SetLength(x, N); SetLength(y, N); For i := 0 to N - 1 do. Begin. If ValueArray <> nil then. Begin. Y[i] := ValueArray[i]; X[i] := ArgumentArray[i]; End. Else. Begin. Y[i] := SourceSeries.YValues.Value[i]; X[i] := SourceSeries.XValues.Value[i]; End; If y[i] <= 0 then. Begin. If Warning then. MessageDlg('Exponent-Power regression inapplicable', MtWarning, [mbOk], 0); Hint := 'No equation'; MainCoef := 0; FreeCoef := 0; Exit; End; Lny := lny + Ln(y[i]); Xsqua := xsqua + x[i] * x[i]; Xlny := xlny + x[i] * Ln(y[i]); End; Xsum := Sum(x); B1 := (xsum * lny - N * xlny) / (xsum * xsum - N * xsqua); B0 := exp((lny - b1 * xsum) / N); MainCoef := b1; FreeCoef := b0; If DestSeries <> nil then. For i := 0 to N - 1 do. If ValueArray <> nil then. DestSeries.AddXY(ArgumentArray[i], B0 * Exp(b1 * ArgumentArray[i]), '', SeriesColor). Else. DestSeries.AddXY(SourceSeries.XValues.Value[i], B0 * Exp(b1 * SourceSeries.XValues.Value[i]), '', SeriesColor); Hint := 'Exponent-Power regression equation: Y = ' + Format('%0.5f', [b0]) + ' * exp(' + Format('%0.5f', [b1]) + ' * X)'; X := nil; Y := nil; End; //Общая процедура проверки массива. Procedure CheckArrayBounds(var CArray: TDoubleArray; var FromPoint, ToPoint: Integer); Begin. If FromPoint < 0 then. FromPoint := 0; If (ToPoint <= 0) or (ToPoint > Length(CArray) - 1) then. ToPoint := Length(CArray) - 1; If FromPoint > ToPoint then. ToPoint := FromPoint; End; //Общая процедура проверки серии. Procedure CheckSeriesBounds(CSeries: TChartSeries; var FromPoint, ToPoint: Integer); Begin. If FromPoint < 0 then. FromPoint := 0; If (ToPoint <= 0) or (ToPoint > CSeries.XValues.Count - 1) then. ToPoint := CSeries.XValues.Count - 1; If FromPoint > ToPoint then. ToPoint := FromPoint; End; //Извлечение массива из массива. Procedure ArrayFromArray(var SourceArray, DestArray: TDoubleArray; FromPoint, ToPoint, Discrete: integer; Derivative: boolean); Var. I: integer; Begin. DestArray := nil; If SourceArray = nil then. DestArray := nil. Else. Begin. CheckArrayBounds(SourceArray, FromPoint, ToPoint); If Discrete = 0 then. Discrete := 1; If Derivative = false then. Begin. SetLength(DestArray, ((ToPoint - FromPoint) div Discrete) + 1); For i := 0 to Length(DestArray) - 1 do. DestArray[i] := SourceArray[i * Discrete + FromPoint]; End. Else. Begin. SetLength(DestArray, ((ToPoint - FromPoint) div Discrete)); For i := 1 to Length(DestArray) do. DestArray[i - 1] := (SourceArray[i * Discrete + FromPoint] - SourceArray[i * Discrete + FromPoint - 1]) / Discrete; End; End; End; //Извлечение массива из серии. Procedure ArrayFromSeries(var ValueArray: TDoubleArray; DataSeries: TChartSeries; FromPoint, ToPoint, Discrete: integer; Derivative: boolean); Var. I: integer; Begin. If DataSeries = nil then. ValueArray := nil. Else. With DataSeries do. Begin. CheckSeriesBounds(DataSeries, FromPoint, ToPoint); If Discrete = 0 then. Discrete := 1; If Derivative = false then. Begin. SetLength(ValueArray, ((ToPoint - FromPoint) div Discrete) + 1); For i := 0 to Length(ValueArray) - 1 do. ValueArray[i] := YValues.Value[i * Discrete + FromPoint]; End. Else. Begin. SetLength(ValueArray, ((ToPoint - FromPoint) div Discrete)); For i := 1 to Length(ValueArray) do. ValueArray[i - 1] := (YValues.Value[i * Discrete + FromPoint] - YValues.Value[i * Discrete. + FromPoint - 1]) / (XValues.Value[i * Discrete + FromPoint] - XValues.Value[i * Discrete + FromPoint - 1]); End; End; End; //Извлечение серии из массива. Procedure SeriesFromArray(var ValueArray: TDoubleArray; DataSeries: TChartSeries; FromPoint, ToPoint, Discrete: integer; Derivative: boolean); Var. I, n: integer; Begin. If DataSeries = nil then. Exit. Else. With DataSeries do. Begin. Clear; CheckArrayBounds(ValueArray, FromPoint, ToPoint); If Discrete = 0 then. Discrete := 1; If Derivative = false then. Begin. N := ((ToPoint - FromPoint) div Discrete) + 1; For i := 0 to n - 1 do. DataSeries.AddXY(i, ValueArray[i * Discrete + FromPoint], '', DataSeries.SeriesColor); End. Else. Begin. N := (ToPoint - FromPoint) div Discrete; For i := 1 to n do. DataSeries.AddXY(i - 1, (ValueArray[i * Discrete + FromPoint] - ValueArray[i * Discrete + FromPoint - 1]) / Discrete, '', DataSeries.SeriesColor); End; End; End; //Извлечение производной из массива. Function DerivFromArray(var SourceArray: TDoubleArray; FromPoint, ToPoint, Discrete: integer; Extremum: string; var Position: integer): double; Var. I: integer; D: double; Begin. DerivFromArray := 0; If SourceArray = nil then. DerivFromArray := 0. Else. Begin. CheckArrayBounds(SourceArray, FromPoint, ToPoint); If Discrete = 0 then. Discrete := 1; SetLength(rv, (ToPoint - FromPoint) div Discrete); For i := 1 to Length(rv) do. Rv[i - 1] := (SourceArray[i * Discrete + FromPoint] - SourceArray[i * Discrete + FromPoint - 1]) / Discrete; If Extremum = 'max' then. D := MaxValue(rv); If Extremum = 'min' then. D := MinValue(rv); If Extremum = 'mean' then. D := Mean(rv); For i := 0 to Length(rv) - 1 do. If rv[i] = d then. Begin. Position := i; Break; End; DerivFromArray := d; End; End; //Извлечение производной из серии. Function DerivFromSeries(DataSeries: TChartSeries; FromPoint, ToPoint, Discrete: integer; Extremum: string; var Position: integer): double; Var. I: integer; D: double; Begin. DerivFromSeries := 0; If DataSeries = nil then. DerivFromSeries := 0. Else. With DataSeries do. Begin. CheckSeriesBounds(DataSeries, FromPoint, ToPoint); If Discrete = 0 then. Discrete := 1; SetLength(rv, (ToPoint - FromPoint) div Discrete); For i := 1 to Length(rv) do. Rv[i - 1] := (YValues.Value[i * Discrete + FromPoint] - YValues.Value[i * Discrete + FromPoint - 1]) / (XValues.Value[i * Discrete + FromPoint] - XValues.Value[i * Discrete + FromPoint - 1]); If Extremum = 'max' then. D := MaxValue(rv); If Extremum = 'min' then. D := MinValue(rv); If Extremum = 'mean' then. D := Mean(rv); For i := 0 to Length(rv) - 1 do. If rv[i] = d then. Begin. Position := i; Break; End; DerivFromSeries := d; End; End; //Извлечение величины из серии. Function ValueFromSeries(DataSeries: TChartSeries; FromPoint, ToPoint: integer; Extremum: string; var Position: integer): double; Var. I: integer; D: double; Begin. If DataSeries = nil then. ValueFromSeries := 0. Else. With DataSeries do. Begin. CheckSeriesBounds(DataSeries, FromPoint, ToPoint); SetLength(rv, ToPoint - FromPoint); For i := 0 to Length(rv) - 1 do. Rv[i] := YValues.Value[FromPoint + i]; If Extremum = 'max' then. D := MaxValue(rv); If Extremum = 'min' then. D := MinValue(rv); If Extremum = 'mean' then. D := Mean(rv); For i := 0 to Length(rv) - 1 do. If rv[i] = d then. Begin. Position := i; Break; End; ValueFromSeries := d; End; End; //Извлечение величины из массива. Function ValueFromArray(var SourceArray: TDoubleArray; FromPoint, ToPoint: integer; Extremum: string; var Position: integer): double; Var. I: integer; D: double; Begin. If SourceArray = nil then. ValueFromArray := 0. Else. Begin. CheckArrayBounds(SourceArray, FromPoint, ToPoint); SetLength(rv, ToPoint - FromPoint); For i := 0 to Length(rv) - 1 do. Rv[i] := SourceArray[FromPoint + i]; If Extremum = 'max' then. D := MaxValue(rv); If Extremum = 'min' then. D := MinValue(rv); If Extremum = 'mean' then. D := Mean(rv); For i := 0 to Length(rv) - 1 do. If rv[i] = d then. Begin. Position := i; Break; End; ValueFromArray := d; End; End; //Вычисление площади под кривой, получаемой данными из массива. Function CalculateAreaOfArray(var SourceArray: TDoubleArray; FromPoint, ToPoint, Method: integer; BindToZero: boolean): double; Var. I: integer; Sq, subv: double; Begin. If SourceArray = nil then. CalculateAreaOfArray := 0. Else. Begin. CheckArrayBounds(SourceArray, FromPoint, ToPoint); Sq := 0; If BindToZero then. Subv := (SourceArray[ToPoint] + SourceArray[FromPoint]) / 2. Else. Subv := 0; For i := FromPoint to ToPoint - 1 do. Begin. If Method = 1 then. Sq := sq + Abs(SourceArray[i] - subv) + (Abs(SourceArray[i + 1] - subv) - Abs(SourceArray[i] - subv)) / 2; If Method = 2 then. Sq := sq + Abs(SourceArray[i] - subv) + (Abs(SourceArray[i + 1] - subv) - Abs(SourceArray[i] - subv)) / 2 - 1. / (48 * Power(0.5, 1.5)); If Method = 3 then. If (i mod 2) = 1 then. Sq := sq + 2 * Abs(SourceArray[i] - subv); If Method = 4 then. If (i mod 2) = 1 then. Sq := sq + 2 * Abs(SourceArray[i] - subv) - 1 / (96 * Power(0.5, 1.5)); End; CalculateAreaOfArray := sq; End; End; //Вычисление площади под кривой, получаемой данными из серии. Function CalculateAreaOfSeries(DataSeries: TChartSeries; FromPoint, ToPoint, Method: integer; BindToZero: boolean): double; Var. I: integer; Sq, subv: double; Begin. If DataSeries = nil then. CalculateAreaOfSeries := 0. Else. With DataSeries do. Begin. CheckSeriesBounds(DataSeries, FromPoint, ToPoint); Sq := 0; If BindToZero then. Subv := (YValues.Value[ToPoint] + YValues.Value[FromPoint]) / 2. Else. Subv := 0; For i := FromPoint to ToPoint - 1 do. Begin. If Method = 1 then. Sq := sq + Abs(YValues.Value[i] - subv) + (Abs(YValues.Value[i + 1] - subv) - Abs(YValues.Value[i] - subv)) / 2; If Method = 2 then. Sq := sq + Abs(YValues.Value[i] - subv) + (Abs(YValues.Value[i + 1] - subv) - Abs(YValues.Value[i] - subv)) / 2 - 1 / (48 * Power(0.5, 1.5)); If Method = 3 then. If (i mod 2) = 1 then. Sq := sq + 2 * Abs(YValues.Value[i] - subv); If Method = 4 then. If (i mod 2) = 1 then. Sq := sq + 2 * Abs(YValues.Value[i] - subv) - 1 / (96 * Power(0.5, 1.5)); End; CalculateAreaOfSeries := sq; End; End; //Исключение линейной составляющей. Procedure LinearTrendExclusion(var ValueArray: TDoubleArray); Var. I, N: integer; B0, b1, nx: double; Begin. N := Length(ValueArray); Nx := 0; For i := 0 to N - 1 do. Nx := nx + (i + 1) * ValueArray[i]; B0 := (2 * (2 * N + 1) * Sum(ValueArray) - 6 * nx) / (N * (N - 1)); B1 := (12 * nx - 6 * (N + 1) * Sum(ValueArray)) / (N * (N - 1) * (N + 1)); For i := 0 to N - 1 do. Begin. ValueArray[i] := ValueArray[i] - (i * b1); End; End; //Расцветка серии. Procedure ColorizeSeries(DataSeries: TChartSeries; NewColor: TColor); Var. I: integer; Begin. For i := 0 to DataSeries.XValues.Count - 1 do. DataSeries.ValueColor[i] := NewColor; End; //Задание нового приращения по оси X. Procedure SetXInterval(DataSeries: TChartSeries; XInterval: double); Var. I: integer; Begin. For i := 0 to DataSeries.XValues.Count - 1 do. DataSeries.XValues.Value[i] := DataSeries.XValues.Value[i] * XInterval; End; //Привязка серии к новой оси. Procedure SetSeriesAxis(DataSeries: TChartSeries; NewAxis: TVertAxis); Begin. DataSeries.VertAxis := NewAxis; End; End.
| Фильтрация, регрессия, работа с массивом и серией |
Code: { **** UBPFD *********** by kladovka.net.ru **** >> Фильтрация, регрессия, работа с массивом и серией. Модуль предназначен для выполнения процедур: - фильтрации. - регрессии. - операций с массивами. - операций с сериями. Зависимости: Math, TeEngine, Graphics, SysUtils, Dialogs. Автор: lookin, lookin@mail.ru, Екатеринбург. Copyright: lookin. Дата: 30 апреля 2002 г. ********************************************** } Unit FilterRegressionArraySeries; Interface. Uses Math, TeEngine, Graphics, SysUtils, Dialogs; Type TIntegerArray = array of integer; Type TExIntegerArray = array of TIntegerArray; Type TDoubleArray = array of double; Type TExDoubleArray = array of TDoubleArray; Type TStringArray = array of string; Type TExStringArray = array of TStringArray; Procedure ArrayExpanding(var ValueArray: TDoubleArray; ExpandCoef: integer); Procedure ArrayLengthening(var ValueArray: TDoubleArray; SplitValue: integer); Procedure ArrayShortening(var ValueArray: TDoubleArray; SplitValue: integer); Procedure CubicSplineSmoothing(var ValueArray: TDoubleArray; Dsc: double; Coef: integer); Procedure SevenPointNonLinearSmoothing(var ValueArray: TDoubleArray; Dsc: double; Coef: integer); Procedure FourierAnalysis(var ValueArray: TDoubleArray; NumGarmonics: integer); Procedure DoArraySmoothing(var ValueArray: TDoubleArray; FilterType: integer; Dsc: double; SplitCoef, ExpandCoef: integer; CycledFilter: boolean); Procedure LinearRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; Var MainCoef,FreeCoef: double; SeriesColor: TColor; Var Hint: string); Procedure HyperbolicRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; Var MainCoef,FreeCoef: double; SeriesColor: TColor; var Hint: string); Procedure PowerRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; Var MainCoef,FreeCoef: double; SeriesColor: TColor; Var Hint: string); Procedure PolynomialRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; PolyDegree: integer; var ArrayCoefs: TDoubleArray; SeriesColor: TColor; var Hint: string); Procedure ExponentRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; Var MainCoef,FreeCoef: double; SeriesColor: TColor; Var Hint: string; Warning: boolean); Procedure ExponentialRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; Var MainCoef,FreeCoef: double; SeriesColor: TColor; Var Hint: string; Warning: boolean); Procedure ExpPowerRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; Var MainCoef,FreeCoef: double; SeriesColor: TColor; Var Hint: string; Warning: boolean); Procedure CheckArrayBounds(var CArray: TDoubleArray; var FromPoint,ToPoint: integer); Procedure CheckSeriesBounds(CSeries: TChartSeries; var FromPoint,ToPoint: integer); Procedure ArrayFromArray(var SourceArray,DestArray: TDoubleArray; FromPoint,ToPoint,Discrete: integer; Derivative: boolean); Procedure ArrayFromSeries(var ValueArray: TDoubleArray; DataSeries: TChartSeries; FromPoint,ToPoint,Discrete: integer; Derivative: boolean); Procedure SeriesFromArray(var ValueArray: TDoubleArray; DataSeries: TChartSeries; FromPoint,ToPoint,Discrete: integer; Derivative: boolean); Function DerivFromArray(var SourceArray: TDoubleArray; FromPoint,ToPoint, Discrete: integer; Extremum: string; Var Position: integer): double; Function DerivFromSeries(DataSeries: TChartSeries; FromPoint,ToPoint, Discrete: integer; Extremum: string; Var Position: integer): double; Function ValueFromSeries(DataSeries: TChartSeries; FromPoint,ToPoint: integer; Extremum: string; var Position: integer): double; Function ValueFromArray(var SourceArray: TDoubleArray; FromPoint,ToPoint: integer; Extremum: string; var Position: integer): double; Function CalculateAreaOfArray(var SourceArray: TDoubleArray; FromPoint,ToPoint,Method: integer; BindToZero: boolean): double; Function CalculateAreaOfSeries(DataSeries: TChartSeries; FromPoint,ToPoint, Method: integer; BindToZero: boolean): double; Procedure LinearTrendExclusion(var ValueArray: TDoubleArray); Procedure ColorizeSeries(DataSeries: TChartSeries; NewColor: TColor); Procedure SetXInterval(DataSeries: TChartSeries; XInterval: double); Procedure SetSeriesAxis(DataSeries: TChartSeries; NewAxis: TVertAxis); Var rv,rsmooth,smootha: TDoubleArray; Implementation. //Нелинейный фильтр по 7 точкам. Procedure SevenPointNonLinearSmoothing(var ValueArray: TDoubleArray; Dsc: double; Coef: integer); Var j,k,i: integer; Resv: array of array of double; Begin. If (Coef=0) or (Coef=1) then Exit; SetLength(resv,Coef,(Length(ValueArray) div Coef)); For j:=0 to Coef-1 do for i:=0 to Length(resv[0])-1 do. Resv[j][i]:=ValueArray[i*Coef+j]; For k:=0 to Coef-1 do for j:=0 to Length(resv[0])-1 do begin. If j=0 then resv[k][j]:=(39*ValueArray[j*Coef+k]+ 8*ValueArray[(j+1)*Coef+k]-4*(ValueArray[(j+2)*Coef+k]+ ValueArray[(j+3)*Coef+k]-ValueArray[(j+4)*Coef+k])+ ValueArray[(j+5)*Coef+k]-2*ValueArray[(j+6)*Coef+k])/42; If j=1 then resv[k][j]:=(8*ValueArray[j*Coef+k]+ 19*ValueArray[(j+1)*Coef+k]+16*ValueArray[(j+2)*Coef+k]+ 6*ValueArray[(j+3)*Coef+k]-4*ValueArray[(j+4)*Coef+k]- 7*ValueArray[(j+5)*Coef+k]+4*ValueArray[(j+6)*Coef+k])/42; If j=2 then resv[k][j]:=(-4*ValueArray[j*Coef+k]+ 16*ValueArray[(j+1)*Coef+k]+19*ValueArray[(j+2)*Coef+k]+ 12*ValueArray[(j+3)*Coef+k]+2*ValueArray[(j+4)*Coef+k]- 4*ValueArray[(j+5)*Coef+k]+ValueArray[(j+6)*Coef+k])/42; If (j>2) and (j<Length(resv[0])-3) then resv[k][j]:= (7*ValueArray[j*Coef+k]+6*(ValueArray[(j-1)*Coef+k]+ ValueArray[(j+1)*Coef+k])+3*(ValueArray[(j-2)*Coef+k]+ ValueArray[(j+2)*Coef+k])-2*(ValueArray[(j-3)*Coef+k]+ ValueArray[(j+3)*Coef+k]))/21; If j=Length(resv[0])-3 then resv[k][j]:=(-4*ValueArray[j*Coef+k]+ 16*ValueArray[(j-1)*Coef+k]+19*ValueArray[(j-2)*Coef+k]+ 12*ValueArray[(j-3)*Coef+k]+2*ValueArray[(j-4)*Coef+k]- 4*ValueArray[(j-5)*Coef+k]+ValueArray[(j-6)*Coef+k])/42; If j=Length(resv[0])-2 then resv[k][j]:=(8*ValueArray[j*Coef+k]+ 19*ValueArray[(j-1)*Coef+k]+16*ValueArray[(j-2)*Coef+k]+ 6*ValueArray[(j-3)*Coef+k]-4*ValueArray[(j-4)*Coef+k]- 7*ValueArray[(j-5)*Coef+k]+4*ValueArray[(j-6)*Coef+k])/42; If j=Length(resv[0])-1 then resv[k][j]:=(39*ValueArray[j*Coef+k]+ 8*ValueArray[(j-1)*Coef+k]-4*ValueArray[(j-2)*Coef+k]- 4*ValueArray[(j-3)*Coef+k]-4*ValueArray[(j-4)*Coef+k]+ ValueArray[(j-5)*Coef+k]-2*ValueArray[(j-6)*Coef+k])/42; end; For j:=Coef to Length(resv[0])-Coef do. For k:=0 to Coef-1 do ValueArray[j*Coef+k]:=resv[k][j]; End; //Фильтр с кубическими сплайнами. Procedure CubicSplineSmoothing(var ValueArray: TDoubleArray; Dsc: double; Coef: integer); Var j,k,i,N: integer; Vresv,resv: array of array of double; Maxv: array of double; Av,h,mi,mj,v1,v2: double; Begin. If (Coef=0) or (Coef=1) then Exit; N:=Length(ValueArray); SetLength(resv,Coef,N); h:=Coef*Dsc; For k:=0 to Coef-1 do for j:=0 to (N div Coef)-2 do begin. If j=0 then begin mi:=(4*ValueArray[(j+1)*Coef+k]- ValueArray[(j+2)*Coef+k]-3*ValueArray[j*Coef+k])/2; Mj:=(ValueArray[(j+2)*Coef+k]-ValueArray[j*Coef+k])/2; end; If j=(N div Coef)-2 then begin. Mi:=(ValueArray[(j+1)*Coef+k]-ValueArray[(j-1)*Coef+k])/2; Mj:=(3*ValueArray[(j+1)*Coef+k]+ValueArray[(j-1)*Coef+k]- 4*ValueArray[j*Coef+k])/2; end; If (j>0) and (j<((N div Coef)-2)) then begin. Mi:=(ValueArray[(j+1)*Coef+k]-ValueArray[(j-1)*Coef+k])/2; Mj:=(ValueArray[(j+2)*Coef+k]-ValueArray[j*Coef+k])/2; end; For i:=j*Coef to (j+1)*Coef do begin. V1:=((j+1)*Coef+k)*Dsc-(i+k)*Dsc; V2:=(i+k)*Dsc-(j*Coef+k)*Dsc; Resv[k][i+k]:=(Sqr(v1)*(2*v2+h)*ValueArray[j*Coef+k]+ Sqr(v2)*(2*v1+h)*ValueArray[(j+1)*Coef+k]+ (Sqr(v1)*v2*mi+Sqr(v2)*(-v1)*mj)/2)/h/h/h; end; end; For j:=Coef to N-1-Coef do begin av:=0; For k:=0 to Coef-1 do av:=av+resv[k][j]; av:=av/Coef; ValueArray[j]:=av; end; End; //Гармонический синтез Фурье. Procedure FourierAnalysis(var ValueArray: TDoubleArray; NumGarmonics: integer); Var i,j,N: integer; Yn,ap,bp: double; AFCoef,BFCoef: TDoubleArray; Begin. N:=Length(ValueArray); SetLength(AFCoef,NumGarmonics); SetLength(BFCoef,NumGarmonics); AFCoef[0]:=Sum(ValueArray)/N; BFCoef[0]:=0; For i:=1 to NumGarmonics-1 do begin AFCoef[i]:=0; BFCoef[i]:=0; For j:=0 to N-1 do begin. AFCoef[i]:=AFCoef[i]+ValueArray[j]*cos(Pi*i*j*2/N); BFCoef[i]:=BFCoef[i]+ValueArray[j]*sin(Pi*i*j*2/N); end; AFCoef[i]:=AFCoef[i]*2/N; BFCoef[i]:=BFCoef[i]*2/N; end; For j:=0 to N-1 do begin yn:=0; ap:=0; bp:=0; For i:=1 to NumGarmonics-1 do begin. Ap:=ap+AFCoef[i]*cos(2*Pi*i*(j/N)); bp:=bp+BFCoef[i]*sin(2*Pi*i*(j/N)); end; Yn:=AFCoef[0]+ap+bp; ValueArray[j]:=yn; end; End; //Общая процедура вызова нужного фильтра. Procedure DoArraySmoothing(var ValueArray: TDoubleArray; FilterType: integer; Dsc: double; SplitCoef, ExpandCoef: integer; CycledFilter: boolean); Var j: integer; Begin. SmoothA:=nil; rsmooth:=ValueArray; ArrayExpanding(rsmooth,ExpandCoef); ArrayLengthening(smoothA,SplitCoef); If FilterType=1 then if CycledFilter then for j:=2 to SplitCoef do. SevenPointNonLinearSmoothing(smoothA,Dsc,j) else. SevenPointNonLinearSmoothing(smoothA,Dsc,SplitCoef); If FilterType=2 then CubicSplineSmoothing(smoothA,Dsc,SplitCoef); ArrayShortening(smoothA,SplitCoef); ValueArray:=smoothA; End; //Расширение массива заданным числом точек справа и слева. Procedure ArrayLengthening(var ValueArray: TDoubleArray; SplitValue: integer); Var sv,N,i: integer; Bv,ev: double; Begin. N:=Length(ValueArray); sv:=10*SplitValue; bv:=0; ev:=0; For i:=0 to 9 do bv:=bv+ValueArray[i]; bv:=bv/10; For i:=N-1 downto N-10 do ev:=ev+ValueArray[i]; ev:=ev/10; SetLength(ValueArray,N+sv); For i:=N-1 downto 0 do ValueArray[i+trunc(sv/2)]:=ValueArray[i]; For i:=trunc(sv/2)-1 downto 0 do ValueArray[i]:=bv; For i:=N+trunc(sv/2) to N+sv-1 do ValueArray[i]:=ev; End; //Сокращение массива заданным числом точек справа и слева. Procedure ArrayShortening(var ValueArray: TDoubleArray; SplitValue: integer); Var sv,N,i: integer; Begin. N:=Length(ValueArray); sv:=10*SplitValue; For i:=0 to N-sv-1 do ValueArray[i]:=ValueArray[i+trunc(sv/2)]; SetLength(ValueArray,N-sv); End; //Расширение массива заданным числом точек между 2-мя соседними. Procedure ArrayExpanding(var ValueArray: TDoubleArray; ExpandCoef: integer); Var i,k,N,sub: integer; Diap: double; Begin. N:=Length(ValueArray); sub:=ExpandCoef-1; SetLength(smoothA,N*ExpandCoef-sub); For i:=0 to N-1 do begin smoothA[i*ExpandCoef]:=ValueArray[i]; If i<>0 then begin diap:=(smoothA[i*ExpandCoef]-smoothA[(i-1)*ExpandCoef]); For k:=0 to ExpandCoef-1 do smoothA[(i-1)*ExpandCoef+k]:= SmoothA[(i-1)*ExpandCoef]+diap*(k/ExpandCoef); end; end; End; //Линейная регрессия. Procedure LinearRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries, DestSeries: TChartSeries; var MainCoef,FreeCoef: double; SeriesColor: TColor; var Hint: string); Var b0,b1,xsum,ysum,pxy,xsqua: double; Y,x: array of double; I,N: integer; S: string; Begin. If ValueArray<>nil then N:=Length(ValueArray) else. N:=SourceSeries.XValues.Count; pxy:=0; xsqua:=0; SetLength(x,N); SetLength(y,N); For i:=0 to N-1 do begin if ValueArray<>nil then begin. Y[i]:=ValueArray[i]; x[i]:=ArgumentArray[i]; end else begin. Y[i]:=SourceSeries.YValues.Value[i]; X[i]:=SourceSeries.XValues.Value[i]; end; Pxy:=pxy+x[i]*y[i]; xsqua:=xsqua+x[i]*x[i]; end; xsum:=Sum(x); ysum:=Sum(y); B1:=(xsum*ysum-N*pxy)/(xsum*xsum-N*xsqua); b0:=(ysum-b1*xsum)/N; MainCoef:=b1; FreeCoef:=b0; If DestSeries<>nil then for i:=0 to N-1 do. If ValueArray<>nil then DestSeries.AddXY(ArgumentArray[i], B1*ArgumentArray[i]+b0,'',SeriesColor) else. DestSeries.AddXY(SourceSeries.XValues.Value[i], B1*SourceSeries.XValues.Value[i]+b0,'',SeriesColor); If b0<0 then s:='' else s:='+ '; Hint:=Format('%0.3f',[b1])+'*X '+s+Format('%0.3f',[b0]); x:=nil; y:=nil; End; //Гиперболическая регрессия. Procedure HyperbolicRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; var MainCoef,FreeCoef: double; SeriesColor: TColor; var Hint: string); Var b0,b1,ax,ysum,axsqua,dxy: double; Y,x: array of double; I,N: integer; S: string; Begin. If ValueArray<>nil then N:=Length(ValueArray) else. N:=SourceSeries.XValues.Count; axsqua:=0; ax:=0; dxy:=0; SetLength(x,N); SetLength(y,N); For i:=0 to N-1 do begin if ValueArray<>nil then begin. Y[i]:=ValueArray[i]; x[i]:=ArgumentArray[i]; end else begin. Y[i]:=SourceSeries.YValues.Value[i]; X[i]:=SourceSeries.XValues.Value[i]; end; If x[i]=0 then begin MessageDlg('Hyperbolic regression inapplicable...', MtWarning,[mbOk],0); Hint:='No equation'; MainCoef:=0; FreeCoef:=0; Exit; end; Dxy:=dxy+y[i]/x[i]; ax:=ax+1/x[i]; axsqua:=axsqua+1/(x[i]*x[i]); end; Ysum:=Sum(y); b1:=(dxy-(ysum*ax)/N)/(axsqua-(ax*ax)/N); b0:=(ysum-b1*ax)/N; MainCoef:=b1; FreeCoef:=b0; If DestSeries<>nil then for i:=0 to N-1 do. If ValueArray<>nil then DestSeries.AddXY(ArgumentArray[i], B1/ArgumentArray[i]+b0,'',SeriesColor) else. DestSeries.AddXY(SourceSeries.XValues.Value[i], B1/SourceSeries.XValues.Value[i]+b0,'',SeriesColor); If b0<0 then s:='' else s:='+ '; Hint:=Format('%0.3f',[b1])+'/X '+s+Format('%0.3f',[b0]); x:=nil; y:=nil; End; //Степенная регрессия. Procedure PowerRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; var MainCoef,FreeCoef: double; SeriesColor: TColor; var Hint: string); Var b0,b1,lnx,lny,xlnsqua,plnxy: double; Y,x: array of double; I,N: integer; Begin. If ValueArray<>nil then N:=Length(ValueArray) else. N:=SourceSeries.XValues.Count; lnx:=0; lny:=0; xlnsqua:=0; plnxy:=0; SetLength(x,N); SetLength(y,N); For i:=0 to N-1 do begin if ValueArray<>nil then begin. Y[i]:=ValueArray[i]; x[i]:=ArgumentArray[i]; end else begin. Y[i]:=SourceSeries.YValues.Value[i]; X[i]:=SourceSeries.XValues.Value[i]; end; If (x[i]<=0) or (y[i]<=0) then begin. MessageDlg('Power regression inapplicable...',mtWarning,[mbOk],0); Hint:='No equation'; MainCoef:=0; FreeCoef:=0; Exit; end; Lnx:=lnx+ln(x[i]); lny:=lny+ln(y[i]); plnxy:=plnxy+ln(x[i])*ln(y[i]); Xlnsqua:=xlnsqua+ln(x[i])*ln(x[i]); end; B1:=(lnx*lny-N*plnxy)/(lnx*lnx-N*xlnsqua); b0:=exp((lny-b1*lnx)/N); MainCoef:=b1; FreeCoef:=b0; If DestSeries<>nil then for i:=0 to N-1 do. If ValueArray<>nil then DestSeries.AddXY(ArgumentArray[i], Power(ArgumentArray[i],b1)*b0,'',SeriesColor) else. DestSeries.AddXY(SourceSeries.XValues.Value[i], Power(SourceSeries.XValues.Value[i],b1)*b0,'',SeriesColor); Hint:=Format('%0.3f',[b0])+'*X^'+Format('%0.3f',[b1]); x:=nil; y:=nil; End; //Полиномиальная регрессия. Procedure PolynomialRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; PolyDegree: integer; Var ArrayCoefs: TDoubleArray; SeriesColor: TColor; var Hint: string); Var bcoef,dcoef: TDoubleArray; Ccoef: array of TDoubleArray; I,j,k,N: integer; Polynom: double; Begin. If ValueArray<>nil then N:=Length(ValueArray) else. N:=SourceSeries.XValues.Count; Hint:=''; ArrayCoefs:=nil; SetLength(ccoef,PolyDegree+1); For i:=0 to Length(ccoef)-1 do SetLength(ccoef[i],PolyDegree+1); SetLength(dcoef,PolyDegree+1); SetLength(bcoef,PolyDegree+1); For i:=0 to Length(dcoef)-1 do begin dcoef[i]:=0; For j:=0 to N-1 do begin if ValueArray<>nil then dcoef[i]:=dcoef[i]+ Power(ArgumentArray[j],i)*ValueArray[j] else. Dcoef[i]:=dcoef[i]+Power(SourceSeries.XValues.Value[j],i)* SourceSeries.YValues.Value[j]; end; For j:=0 to Length(ccoef)-1 do begin ccoef[i][j]:=0; For k:=0 to N-1 do begin if ValueArray<>nil then ccoef[i][j]:= Ccoef[i][j]+Power(ArgumentArray[k],i+j) else. Ccoef[i][j]:=ccoef[i][j]+Power(SourceSeries.XValues.Value[k],i+j); End; end; end; For i:=0 to Length(ccoef)-2 do for j:=i+1 to Length(ccoef)-1 do begin. Ccoef[j][i]:=-ccoef[j][i]/ccoef[i][i]; Dcoef[j]:=dcoef[j]+ccoef[j][i]*dcoef[i]; For k:=i+1 to Length(ccoef)-1 do. Ccoef[j][k]:=ccoef[j][k]+ccoef[j][i]*ccoef[i][k]; end; Bcoef[Length(bcoef)-1]:=dcoef[Length(dcoef)-1]/ Ccoef[Length(bcoef)-1][Length(bcoef)-1]; For i:=Length(ccoef)-2 downto 0 do begin. For j:=i+1 to Length(ccoef)-1 do bcoef[i]:=bcoef[i]+bcoef[j]*ccoef[i][j]; Bcoef[i]:=(dcoef[i]-bcoef[i])/ccoef[i][i]; end; SetLength(ArrayCoefs,Length(bcoef)); For i:=0 to Length(bcoef)-1 do ArrayCoefs[i]:=bcoef[i]; If DestSeries<>nil then for i:=0 to N-1 do begin polynom:=0; If ValueArray<>nil then begin. For j:=0 to PolyDegree do polynom:=polynom+bcoef[j]*Power(ArgumentArray[i],j); DestSeries.AddXY(ArgumentArray[i],polynom,'',SeriesColor); end else begin. For j:=0 to PolyDegree do polynom:=polynom+ Bcoef[j]*Power(SourceSeries.XValues.Value[i],j); DestSeries.AddXY(SourceSeries.XValues.Value[i], Polynom,'',SeriesColor); end; end; For j:=PolyDegree downto 0 do. Hint:=Hint+Format('%0.3f',[bcoef[j]])+'*X^'+IntToStr(j); Dcoef:=nil; bcoef:=nil; ccoef:=nil; End; //Показательная регрессия. Procedure ExponentRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; var MainCoef,FreeCoef: double; SeriesColor: TColor; var Hint: string; Warning: boolean); Var i,N: integer; X,y: array of double; Lgy,xsum,xsqua,a,b,lga,xlgy,lgb: double; Begin. If ValueArray<>nil then N:=Length(ValueArray) else. N:=SourceSeries.XValues.Count; lgy:=0; xsqua:=0; xlgy:=0; SetLength(x,N); SetLength(y,N); For i:=0 to N-1 do begin if ValueArray<>nil then begin. Y[i]:=ValueArray[i]; x[i]:=ArgumentArray[i]; end else begin. Y[i]:=SourceSeries.YValues.Value[i]; X[i]:=SourceSeries.XValues.Value[i]; end; If y[i]<=0 then begin if Warning then. MessageDlg('Exponent regression inapplicable', MtWarning,[mbOk],0); Hint:='No equation'; MainCoef:=0; FreeCoef:=0; Exit; end; Lgy:=lgy+Log10(y[i]); xsqua:=xsqua+x[i]*x[i]; Xlgy:=xlgy+x[i]*Log10(y[i]); end; xsum:=Sum(x); Lgb:=(xlgy-(lgy*xsum)/N)/(xsqua-(xsum*xsum)/N); lga:=(lgy-lgb*xsum)/N; B:=Power(10,lgb); a:=Power(10,lga); MainCoef:=b; FreeCoef:=a; If DestSeries<>nil then for i:=0 to N-1 do. If ValueArray<>nil then DestSeries.AddXY(ArgumentArray[i], A*Power(b,ArgumentArray[i]),'',SeriesColor) else. DestSeries.AddXY(SourceSeries.XValues.Value[i], A*Power(b,SourceSeries.XValues.Value[i]),'',SeriesColor); Hint:='Exponent regression equation: Y = '+ Format('%0.5f',[a])+' * ('+Format('%0.5f',[b])+' ^ X)'; x:=nil; y:=nil; End; //Экспоненциальная регрессия. Procedure ExponentialRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; var MainCoef,FreeCoef: double; SeriesColor: TColor; var Hint: string; Warning: boolean); Var i,N: integer; X,y: array of double; Lny,xsum,xsqua,xlny,b0,b1: double; Begin. MainCoef:=0; FreeCoef:=0; If ValueArray<>nil then N:=Length(ValueArray) else. N:=SourceSeries.XValues.Count; lny:=0; xsqua:=0; xlny:=0; SetLength(x,N); SetLength(y,N); For i:=0 to N-1 do begin if ValueArray<>nil then begin. Y[i]:=ValueArray[i]; x[i]:=ArgumentArray[i]; end else begin. Y[i]:=SourceSeries.YValues.Value[i]; X[i]:=SourceSeries.XValues.Value[i]; end; If y[i]<=0 then begin if Warning then. MessageDlg('Exponential regression inapplicable', MtWarning,[mbOk],0); Hint:='No equation'; MainCoef:=0; FreeCoef:=0; Exit; end; Lny:=lny+Ln(y[i]); xsqua:=xsqua+x[i]*x[i]; Xlny:=xlny+x[i]*Ln(y[i]); end; xsum:=Sum(x); B1:=(xsum*lny-N*xlny)/(xsum*xsum-N*xsqua); b0:=exp((lny-b1*xsum)/N); MainCoef:=b1; FreeCoef:=b0; If DestSeries<>nil then for i:=0 to N-1 do. If ValueArray<>nil then DestSeries.AddXY(ArgumentArray[i], B0*Exp(b1*ArgumentArray[i]),'',SeriesColor) else. DestSeries.AddXY(SourceSeries.XValues.Value[i], B0*Exp(b1*SourceSeries.XValues.Value[i]),'',SeriesColor); Hint:='Exponential regression equation: Y = '+ Format('%0.5f',[b0])+' * exp('+Format('%0.5f',[b1])+' * X)'; x:=nil; y:=nil; End; //Степенно-экспоненциальная регрессия. Procedure ExpPowerRegression(ValueArray,ArgumentArray: TDoubleArray; SourceSeries,DestSeries: TChartSeries; var MainCoef,FreeCoef: double; SeriesColor: TColor; var Hint: string; Warning: boolean); Var i,N: integer; X,y: array of double; Matr: array [0..3] of double; Lny,xsum,xsqua,xlny,b0,b1: double; Begin. MainCoef:=0; FreeCoef:=0; If ValueArray<>nil then N:=Length(ValueArray) else. N:=SourceSeries.XValues.Count; lny:=0; xsqua:=0; xlny:=0; SetLength(x,N); SetLength(y,N); For i:=0 to N-1 do begin if ValueArray<>nil then begin. Y[i]:=ValueArray[i]; x[i]:=ArgumentArray[i]; end else begin. Y[i]:=SourceSeries.YValues.Value[i]; X[i]:=SourceSeries.XValues.Value[i]; end; If y[i]<=0 then begin if Warning then. MessageDlg('Exponent-Power regression inapplicable', MtWarning,[mbOk],0); Hint:='No equation'; MainCoef:=0; FreeCoef:=0; Exit; end; Lny:=lny+Ln(y[i]); xsqua:=xsqua+x[i]*x[i]; Xlny:=xlny+x[i]*Ln(y[i]); end; xsum:=Sum(x); B1:=(xsum*lny-N*xlny)/(xsum*xsum-N*xsqua); b0:=exp((lny-b1*xsum)/N); MainCoef:=b1; FreeCoef:=b0; If DestSeries<>nil then for i:=0 to N-1 do. If ValueArray<>nil then DestSeries.AddXY(ArgumentArray[i], B0*Exp(b1*ArgumentArray[i]),'',SeriesColor) else. DestSeries.AddXY(SourceSeries.XValues.Value[i], B0*Exp(b1*SourceSeries.XValues.Value[i]),'',SeriesColor); Hint:='Exponent-Power regression equation: Y = '+ Format('%0.5f',[b0])+' * exp('+Format('%0.5f',[b1])+' * X)'; x:=nil; y:=nil; End; //Общая процедура проверки массива. Procedure CheckArrayBounds(var CArray: TDoubleArray; var FromPoint,ToPoint: integer); Begin. If FromPoint<0 then FromPoint:=0; If (ToPoint<=0) or (ToPoint>Length(CArray)-1) then ToPoint:=Length(CArray)-1; If FromPoint>ToPoint then ToPoint:=FromPoint; End; //Общая процедура проверки серии. Procedure CheckSeriesBounds(CSeries: TChartSeries; var FromPoint,ToPoint: integer); Begin. If FromPoint<0 then FromPoint:=0; If (ToPoint<=0) or (ToPoint>CSeries.XValues.Count-1) then. ToPoint:=CSeries.XValues.Count-1; If FromPoint>ToPoint then ToPoint:=FromPoint; End; //Извлечение массива из массива. Procedure ArrayFromArray(var SourceArray,DestArray: TDoubleArray; FromPoint,ToPoint,Discrete: integer; Derivative: boolean); Var i: integer; Begin. DestArray:=nil; If SourceArray=nil then DestArray:=nil else begin. CheckArrayBounds(SourceArray,FromPoint,ToPoint); If Discrete=0 then Discrete:=1; If Derivative=false then begin. SetLength(DestArray,((ToPoint-FromPoint) div Discrete)+1); For i:=0 to Length(DestArray)-1 do DestArray[i]:= SourceArray[i*Discrete+FromPoint]; end else begin. SetLength(DestArray,((ToPoint-FromPoint) div Discrete)); For i:=1 to Length(DestArray) do DestArray[i-1]:= (SourceArray[i*Discrete+FromPoint]- SourceArray[i*Discrete+FromPoint-1])/Discrete; end; end; End; //Извлечение массива из серии. Procedure ArrayFromSeries(var ValueArray: TDoubleArray; DataSeries: TChartSeries; FromPoint,ToPoint,Discrete: integer; Derivative: boolean); Var i: integer; Begin. If DataSeries=nil then ValueArray:=nil else with DataSeries do begin. CheckSeriesBounds(DataSeries,FromPoint,ToPoint); If Discrete=0 then Discrete:=1; If Derivative=false then begin. SetLength(ValueArray,((ToPoint-FromPoint) div Discrete)+1); For i:=0 to Length(ValueArray)-1 do ValueArray[i]:= YValues.Value[i*Discrete+FromPoint]; end else begin. SetLength(ValueArray,((ToPoint-FromPoint) div Discrete)); For i:=1 to Length(ValueArray) do ValueArray[i-1]:= (YValues.Value[i*Discrete+FromPoint]-YValues.Value[i*Discrete+FromPoint-1])/ (XValues.Value[i*Discrete+FromPoint]- XValues.Value[i*Discrete+FromPoint-1]); end; end; End; //Извлечение серии из массива. Procedure SeriesFromArray(var ValueArray: TDoubleArray; DataSeries: TChartSeries; FromPoint,ToPoint,Discrete: integer; Derivative: boolean); Var i,n: integer; Begin. If DataSeries=nil then Exit else with DataSeries do begin Clear; CheckArrayBounds(ValueArray,FromPoint,ToPoint); If Discrete=0 then Discrete:=1; If Derivative=false then begin n:=((ToPoint-FromPoint) div Discrete)+1; For i:=0 to n-1 do DataSeries.AddXY(i,ValueArray[i*Discrete+FromPoint], '',DataSeries.SeriesColor); end else begin. N:=(ToPoint-FromPoint) div Discrete; For i:=1 to n do DataSeries.AddXY(i-1,(ValueArray[i*Discrete+FromPoint]- ValueArray[i*Discrete+FromPoint-1])/Discrete, '',DataSeries.SeriesColor); end; end; End; //Извлечение производной из массива. Function DerivFromArray(var SourceArray: TDoubleArray; FromPoint,ToPoint, Discrete: integer; Extremum: string; var Position: integer): double; Var i: integer; D: double; Begin. DerivFromArray:=0; If SourceArray=nil then DerivFromArray:=0 else begin. CheckArrayBounds(SourceArray,FromPoint,ToPoint); If Discrete=0 then Discrete:=1; SetLength(rv,(ToPoint-FromPoint) div Discrete); For i:=1 to Length(rv) do rv[i-1]:=(SourceArray[i*Discrete+FromPoint]- SourceArray[i*Discrete+FromPoint-1])/Discrete; If Extremum='max' then d:=MaxValue(rv); If Extremum='min' then d:=MinValue(rv); If Extremum='mean' then d:=Mean(rv); For i:=0 to Length(rv)-1 do. If rv[i]=d then begin Position:=i; break; end; DerivFromArray:=d; end; End; //Извлечение производной из серии. Function DerivFromSeries(DataSeries: TChartSeries; FromPoint,ToPoint, Discrete: integer; Extremum: string; var Position: integer): double; Var i: integer; D: double; Begin. DerivFromSeries:=0; If DataSeries=nil then DerivFromSeries:=0 else with DataSeries do begin. CheckSeriesBounds(DataSeries,FromPoint,ToPoint); If Discrete=0 then Discrete:=1; SetLength(rv,(ToPoint-FromPoint) div Discrete); For i:=1 to Length(rv) do rv[i-1]:=(YValues.Value[i*Discrete+FromPoint]- YValues.Value[i*Discrete+FromPoint-1])/(XValues.Value[i*Discrete+FromPoint]- XValues.Value[i*Discrete+FromPoint-1]); If Extremum='max' then d:=MaxValue(rv); If Extremum='min' then d:=MinValue(rv); If Extremum='mean' then d:=Mean(rv); For i:=0 to Length(rv)-1 do. If rv[i]=d then begin Position:=i; break; end; DerivFromSeries:=d; end; End; //Извлечение величины из серии. Function ValueFromSeries(DataSeries: TChartSeries; FromPoint,ToPoint: integer; Extremum: string; var Position: integer): double; Var i: integer; D: double; Begin. If DataSeries=nil then ValueFromSeries:=0 else with DataSeries do begin. CheckSeriesBounds(DataSeries,FromPoint,ToPoint); SetLength(rv,ToPoint-FromPoint); For i:=0 to Length(rv)-1 do rv[i]:=YValues.Value[FromPoint+i]; If Extremum='max' then d:=MaxValue(rv); If Extremum='min' then d:=MinValue(rv); If Extremum='mean' then d:=Mean(rv); For i:=0 to Length(rv)-1 do. If rv[i]=d then begin Position:=i; break; end; ValueFromSeries:=d; end; End; //Извлечение величины из массива. Function ValueFromArray(var SourceArray: TDoubleArray; FromPoint, ToPoint: integer; Extremum: string; var Position: integer): double; Var i: integer; D: double; Begin. If SourceArray=nil then ValueFromArray:=0 else begin. CheckArrayBounds(SourceArray,FromPoint,ToPoint); SetLength(rv,ToPoint-FromPoint); For i:=0 to Length(rv)-1 do rv[i]:=SourceArray[FromPoint+i]; If Extremum='max' then d:=MaxValue(rv); If Extremum='min' then d:=MinValue(rv); If Extremum='mean' then d:=Mean(rv); For i:=0 to Length(rv)-1 do. If rv[i]=d then begin Position:=i; break; end; ValueFromArray:=d; end; End; //Вычисление площади под кривой, получаемой данными из массива. Function CalculateAreaOfArray(var SourceArray: TDoubleArray; FromPoint,ToPoint,Method: integer; BindToZero: boolean): double; Var i: integer; Sq,subv: double; Begin. If SourceArray=nil then CalculateAreaOfArray:=0 else begin. CheckArrayBounds(SourceArray,FromPoint,ToPoint); sq:=0; If BindToZero then subv:= (SourceArray[ToPoint]+SourceArray[FromPoint])/2 else subv:=0; For i:=FromPoint to ToPoint-1 do begin. If Method=1 then sq:=sq+Abs(SourceArray[i]-subv)+ (Abs(SourceArray[i+1]-subv)-Abs(SourceArray[i]-subv))/2; If Method=2 then sq:=sq+Abs(SourceArray[i]-subv)+ (Abs(SourceArray[i+1]-subv)-Abs(SourceArray[i]-subv))/2-1/(48*Power(0.5,1.5)); If Method=3 then if (i mod 2)=1 then sq:=sq+2*Abs(SourceArray[i]-subv); If Method=4 then if (i mod 2)=1 then. Sq:=sq+2*Abs(SourceArray[i]-subv)-1/(96*Power(0.5,1.5)); end; CalculateAreaOfArray:=sq; end; End; //Вычисление площади под кривой, получаемой данными из серии. Function CalculateAreaOfSeries(DataSeries: TChartSeries; FromPoint,ToPoint, Method: integer; BindToZero: boolean): double; Var i: integer; Sq,subv: double; Begin. If DataSeries=nil then CalculateAreaOfSeries:=0 else with DataSeries do begin. CheckSeriesBounds(DataSeries,FromPoint,ToPoint); sq:=0; If BindToZero then subv:=(YValues.Value[ToPoint]+ YValues.Value[FromPoint])/2 else subv:=0; For i:=FromPoint to ToPoint-1 do begin. If Method=1 then sq:=sq+Abs(YValues.Value[i]-subv)+ (Abs(YValues.Value[i+1]-subv)-Abs(YValues.Value[i]-subv))/2; If Method=2 then sq:=sq+Abs(YValues.Value[i]-subv)+ (Abs(YValues.Value[i+1]-subv)- Abs(YValues.Value[i]-subv))/2-1/(48*Power(0.5,1.5)); If Method=3 then if (i mod 2)=1 then sq:=sq+2*Abs(YValues.Value[i]-subv); If Method=4 then if (i mod 2)=1 then. Sq:=sq+2*Abs(YValues.Value[i]-subv)-1/(96*Power(0.5,1.5)); end; CalculateAreaOfSeries:=sq; end; End; //Исключение линейной составляющей. Procedure LinearTrendExclusion(var ValueArray: TDoubleArray); Var i,N: integer; B0,b1,nx: double; Begin. N:=Length(ValueArray); nx:=0; For i:=0 to N-1 do nx:=nx+(i+1)*ValueArray[i]; B0:=(2*(2*N+1)*Sum(ValueArray)-6*nx)/(N*(N-1)); B1:=(12*nx-6*(N+1)*Sum(ValueArray))/(N*(N-1)*(N+1)); For i:=0 to N-1 do begin ValueArray[i]:=ValueArray[i]-(i*b1); end; End; //Расцветка серии. Procedure ColorizeSeries(DataSeries: TChartSeries; NewColor: TColor); Var i: integer; Begin. For i:=0 to DataSeries.XValues.Count-1 do. DataSeries.ValueColor[i]:=NewColor; End; //Задание нового приращения по оси X. Procedure SetXInterval(DataSeries: TChartSeries; XInterval: double); Var i: integer; Begin. For i:=0 to DataSeries.XValues.Count-1 do. DataSeries.XValues.Value[i]:=DataSeries.XValues.Value[i]*XInterval; End; //Привязка серии к новой оси. Procedure SetSeriesAxis(DataSeries: TChartSeries; NewAxis: TVertAxis); Begin. DataSeries.VertAxis:=NewAxis; End; End.
| Фильтрованный поиск в строке |
Автор: David Stidolph.
| Учимся работать с "многопоточными файлами" в NT. |
1. Создание(изменение) и чтение "Опциональных потоков".
Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. //сохраняем то что в Memo в "многопоточный файл". Memo1.Lines.SaveToFile('k:\memo.txt'); Memo2.Lines.SaveToFile('k:\memo.txt:memo2'); //опциональный поток. End; Procedure TForm1.Button2Click(Sender: TObject); Begin. //читаем в обратном порядке из "многопоточного файла". Memo1.Lines.LoadFromFile('k:\memo.txt:memo2'); //опциональный поток. Memo2.Lines.LoadFromFile('k:\memo.txt'); End;
Учимся работать с POP3 по tе1nеtу.
| Учимся работать с POP3 по telnetу |
Учимся работать с POP3 по telnetу.
Как люди получают почту, другими словами, вы никогда не задумывались,
что делает ваш почтовый клиент в интернете, чтобы получить ее?
Я попытаюсь удовлетворить ваше любопытство...
Возможно будет несколько незнакомых терминов, но для их понимания советую
почитать учебник по семейству протоколов TCP/IP.
Итак, в настройках почтового клиента вы вводите
Smtp_server ( сервер для передачи писем, написанных вами ).
Pop3_server ( вот с ним-то мы и поэкспериментируем ).
Pop3_login ( требуются для регистрации на pop3_server'e ).
Pop3_pass.
При отправлении вашей почты клиент создает tcp-соединение
с адресом smtp_server порт 25 и грубо говоря пихает в этот порт вашу почту
Plain текстом.
Если вы хотите получить свою почту, то почтовый клиент
A) соединяется с pop3_server на порт 110.
B) выполняет процедуру регистрации и
C) скачивает письма и последовательно их удаляет.
Все это можно проделать и в ручную, чтобы :
1) удовлетворить свое любопытство на практике
2) посмотреть, в чем проблема, если почта не скачивается
3) читать чужую почту ( если знаем pop3-login & pass ).
4) попробовать подобрать пароли на почту
Итак, сидя из Windows95, мы запускаем
Telnet.exe с параметрами: pop3_server 110.
Таким образом, мы выполнили функцию a) клиента
Далее, получив приглашение
+OK sendmail POP3 Server (Version F.U.C.K) ready at <01.01.80>
мы можем вводить команды:
Команда (в качестве ответа на них сервер выдает +OK comments).
USER pop3_login Логин пользователя
PASS pop3_pass Пароль пользователя
LIST Посмотреть состояние ящика
STAT Скольно писем и какой объем
RETR X Скачать письмо номер X.
TOP X Y Посмотреть Y строчек (начиная с тела) X письма
( удобно, если ваш ящик забомбили большими файлами,
и вы можете удалить нужное письмо, не скачивая его).
В принципе это может делать The Bat! mailer.
( dispatch mail on server ).
DELE X Удалить письмо с номером X.
QUIT Выход
Теперь мы удовлетворили любопытство и переходим к серьезным вещам.
2) если существует проблема с регистрацией, то полные комментарии можно
получить в отрицательном ответе сервера ("-ERR"), например
USER lalal.
-ERR invalid usercode or password.
3) Читать чужую почту, по возможности не оставляя следов.
Используем ТОЛЬКО команды RETR/TOP после регистрации.
Естественно, не надо удалять письма командой DELE!
Останутся ли следы ?
В принципе при скачивании почты в письмо добавляется флаг
Status: RO.
Он по умолчанию не виден в почтовом клиенте, но если включить что-то
типа show raw message, то пользователь-параноик может понять, в чем дело.
=> Если вы получаете почту с таким флагом, значит кто-то ее уже прочитал.
4) Подбор паролей по POP3.
В некоторых ( в большинстве?) демонах возможно неограниченное число попыток
регистрации на Pop3 сервере. Само собой, это можно использовать для подбора
паролей.
Исходники под Unix pop3hack.c можно найти на www.rootshell.com.
Edited on 05/07/1999 23:52:26.
QWERTY.NANKO.RU.
©Drkb::03384.
Типы.
| Типы |
14. Типы.
ВВЕДЕНИЕ.
В последней главе (Часть 13, Процедуры) я упомянул, что в ней и в следующей главе мы рассмотрим две возможности, которые помогут отделить игрушечный язык от настоящего, пригодного к использованию. В ней мы рассмотрели вызовы процедур. Многие из вас терпеливо ждали, начиная с Августа'89 когда я выдам вторую. Хорошо, вот она.
В этой главе мы поговорим о том, как работать с различными типами данных. Как и в последней главе, я не буду сейчас включать эти возможности непосредственно в компилятор TINY. Вместо этого я буду использовать тот же самый подход, который так хорошо служил нам в прошлом: использование только фрагментов синтаксического анализатора и одно-символьных токенов. Как обычно, это позволит нам добраться непосредственно до сути вопроса не продираясь сквозь массу ненужного кода. Так как основные проблемы при работе с множественными типами данных возникают в арифметических операциях, на них мы и сконцентрируем свое внимание.
Несколько предупреждений: Во-первых, есть некоторые типы, которые я не буду охватывать в этой главе. Здесь мы будем говорить только о простых, встроенных типах. Мы даже не будем работать с массивами, указателями или строками, я охвачу их в следующих нескольких главах.
Во-вторых, мы также не будем обсуждать и типы, определяемые пользователем. Это будет значительно позже, по той простой причине, что я все еще не убедил себя, что эти определяемые пользователем типы должны быть в языке KISS. В более поздних главах я собираюсь охватить по крайней мере основные концепции определяемых пользователем типов, записей и т.д., просто для того, чтобы серия была полной. Но действительно ли они будут включены как часть KISS - все еще открытый вопрос. Я открыт для комментариев и предложений по этой теме.
Наконец, я должен предупредить вас: то, что мы собираемся сделать может добавить массу дополнительных сложностей и в синтаксический анализатор и в генерируемый код. Поддерживать различные типы достаточно просто. Сложность возникает когда вы добавляете правила преобразования между типами. Вообще-то, будет ли ваш компилятор простым или сложным зависит от способа, выбранного вами для определения правил преобразования типов. Даже если вы решите запретить любые преобразования типов (как в Ada, например) проблема все еще остается, и она встроена в математику. Когда вы умножаете два коротких числа, к примеру, вы можете получить длинный результат.
Я подошел к этой проблеме очень осторожно, пытаясь сохранить простоту. Но мы не можем полностью избежать сложности. Как обычно случается, мы оказываемся перед необходимостью выбирать между качеством кода и сложностью и, как обычно, я предпочитаю выбрать самый простой подход.
ЧТО БУДЕТ ДАЛЬШЕ?
Прежде чем мы погрузимся в это занятие, я думаю вам бы хотелось знать что мы сейчас собираемся делать... особенно после того, как прошло столько много времени с прошлой главы.
Тем временем я не бездействовал. Я разбил компилятор на модули. Одна из проблем, с которыми я столкнулся, в том, что так как мы охватывали новые области и вследствие этого расширяли возможности компилятора TINY, он становился все больше и больше. Я понял пару глав назад, что это приводило к затруднениям и именно поэтому я возвратился к использованию только фрагментов компилятора в последней и этой главах. Кажется просто глупо заново воспроизводить код для, скажем, обработки булевых исключающих ИЛИ, когда тема дискуссии - передача параметров.
Очевидным способом получит свой пирог и съесть его также является разбиение компилятора на раздельно компилируемые модули и, конечно, модули Turbo Pascal являются для этого идеальным средством. Это позволит нам скрыть некоторый довольно сложный код (такой как полный синтаксический анализ арифметических и булевых выражений) в одиночный модуль и просто вытаскивать его всякий раз когда он необходим. При таком способе единственным кодом, который я должен буду воспроизводить в этих главах, будет код который непосредственно касается обсуждаемого вопроса.
Я также игрался с Turbo 5.5 который, конечно, включает Борландовские объектно-ориентированные расширения Паскаля. Я не решил, использовать ли эти возможности, по двум причинам. Прежде всего, многие из вас, кто следовал за этой серией, могут все еще не иметь 5.5 и я конечно не хочу вынуждать кого-либо пойти и купить новый компилятор только для того, чтобы завершить эту серию. Во-вторых, я не убежден, что ОО расширения имеют такое большое значение для этого приложения. Мы обсуждали кое-что из этого на форуме CLM на CompuServe, и пока что мы не нашли никакой убедительной причины для использования ОО конструкции. Это одна из тех областей, где я мог бы использовать некоторую обратную связь с читателями. Кто-нибудь хочет проголосовать за Turbo 5.5 и ООП? В любом случае после следующих нескольких глав этой серии я планирую предоставить вам законченный набор модулей а также законченные функционирующие компиляторы. Планом фактически предусмотрено три компилятора: один для одно-символьной версии TINY (для использования в наших экспериментах), один для TINY и один для KISS. Я достаточно четко выделил различия между TINY и KISS:
· TINY будет поддерживать только два типа данных: символьный и 16-разрядное целое число. Я могу также попробовать сделать что-нибудь со строками, так как без них компилятор был бы довольно бесполезным. KISS будет поддерживать все обычные простые типы, включая массивы и даже числа с плавающей точкой.
· TINY будет иметь только две управляющие конструкции IF и WHILE. KISS будет поддерживать очень богатый набор конструкций включая одну, которую мы не обсуждали здесь ранее... CASE.
· KISS будет поддерживать раздельно компилируемые модули.
Одно предостережение: так как я все еще не знаю достаточно об ассемблере для 80x86, все эти модули компилятора все еще будут написаны для поддержки кода 68000. Однако в программах, которые я планирую вам представить, вся генерация кода была тщательно изолирована в отдельном модуле, так что любой предприимчивый студент смог бы перенастроить их на любой другой процессор. Эта задача "оставлена как упражнение для студента". Я сделаю предложение прямо здесь и сейчас: с человеком, который предоставит нам первый надежный перевод для 80x86, я буду счастлив обсудить коллективные авторские права и авторские отчисления от предстоящей книги.
Но хватит говорить. Давайте приступим к изучению типов. Как я сказал ранее, мы будем делать это как и в последней главе: выполняя эксперименты с использованием одно-символьных токенов.
ТАБЛИЦА ИДЕНТИФИКАТОРОВ.
Должно быть очевидным, что если мы собираемся работать с переменными различных типов, нам понадобится какое-то место для записи их типов. Очевидным средством для этого является таблица идентификаторов и мы уже использовали ее например для различия между локальными и глобальными переменными и между переменными и процедурами. Структура таблицы идентификаторов для одно-символьных токенов особенно проста и мы использовали ее прежде несколько раз. Для работы с ней, мы возьмем некоторые процедуры, которые мы использовали раньше.
Сначала, нам необходимо объявить саму таблицу идентификаторов:
Code: { Variable Declarations }. Var Look: char; { Lookahead Character }. ST: Array['A'..'Z'] of char; { *** ДОБАВЬТЕ ЭТУ СТРОКУ ***}.
Затем мы должны удостовериться, что она инициализируется в процедуре Init:
Code: { Initialize }. Procedure Init; Var i: char; Begin. For i := 'A' to 'Z' do. ST[i] := '?'; GetChar; End;
Следующая процедура в действительности нам не нужна, но она будет полезна для отладки. Все, что она делает, это формирует дамп содержимого таблицы идентификаторов:
Code: { Dump the Symbol Table }. Procedure DumpTable; Var i: char; Begin. For i := 'A' to 'Z' do. WriteLn(i, ' ', ST[i]); End;
В действительности не имеет значения, где вы поместите эту процедуру... я планирую группировать все подпрограммы таблицы идентификаторов вместе, так что я поместил ее сразу после процедур сообщений об ошибках.
Если вы осторожный тип (как я), вам возможно захотелось бы начать с тестовой программы, которая ничего не делает а просто инициализирует таблицу и затем создает ее дамп. Только для того, чтобы быть уверенным, что все мы находимся на одной волне, ниже я воспроизвожу всю программу, дополненную новыми процедурами. Заметьте, что эта версия включает поддержку пробелов:
Code: Program Types; { Constant Declarations }. Const TAB = ^I; CR = ^M; LF = ^J; { Variable Declarations }. Var Look: char; { Lookahead Character }. ST: Array['A'..'Z'] of char; { Read New Character From Input Stream }. Procedure GetChar; Begin. Read(Look); End; { Report an Error }. Procedure Error(s: string); Begin. WriteLn; WriteLn(^G, 'Error: ', s, '.'); End; { Report Error and Halt }. Procedure Abort(s: string); Begin. Error(s); Halt; End; { Report What Was Expected }. Procedure Expected(s: string); Begin. Abort(s + ' Expected'); End; { Dump the Symbol Table }. Procedure DumpTable; Var i: char; Begin. For i := 'A' to 'Z' do. WriteLn(i, ' ', ST[i]); End; { Recognize an Alpha Character }. Function IsAlpha(c: char): boolean; Begin. IsAlpha := UpCase(c) in ['A'..'Z']; End; { Recognize a Decimal Digit }. Function IsDigit(c: char): boolean; Begin. IsDigit := c in ['0'..'9']; End; { Recognize an AlphaNumeric Character }. Function IsAlNum(c: char): boolean; Begin. IsAlNum := IsAlpha(c) or IsDigit(c); End; { Recognize an Addop }. Function IsAddop(c: char): boolean; Begin. IsAddop := c in ['+', '-']; End; { Recognize a Mulop }. Function IsMulop(c: char): boolean; Begin. IsMulop := c in ['*', '/']; End; { Recognize a Boolean Orop }. Function IsOrop(c: char): boolean; Begin. IsOrop := c in ['|', '~']; End; { Recognize a Relop }. Function IsRelop(c: char): boolean; Begin. IsRelop := c in ['=', '#', '<', '>']; End; { Recognize White Space }. Function IsWhite(c: char): boolean; Begin. IsWhite := c in [' ', TAB]; End; { Skip Over Leading White Space }. Procedure SkipWhite; Begin. While IsWhite(Look) do. GetChar; End; { Skip Over an End-of-Line }. Procedure Fin; Begin. If Look = CR then begin. GetChar; If Look = LF then. GetChar; End; End; { Match a Specific Input Character }. Procedure Match(x: char); Begin. If Look = x then GetChar. Else Expected('''' + x + ''''); SkipWhite; End; { Get an Identifier }. Function GetName: char; Begin. If not IsAlpha(Look) then Expected('Name'); GetName := UpCase(Look); GetChar; SkipWhite; End; { Get a Number }. Function GetNum: char; Begin. If not IsDigit(Look) then Expected('Integer'); GetNum := Look; GetChar; SkipWhite; End; { Output a String with Tab }. Procedure Emit(s: string); Begin. Write(TAB, s); End; { Output a String with Tab and CRLF }. Procedure EmitLn(s: string); Begin. Emit(s); WriteLn; End; { Initialize }. Procedure Init; Var i: char; Begin. For i := 'A' to 'Z' do. ST[i] := '?'; GetChar; SkipWhite; End; { Main Program }. Begin. Init; DumpTable; End.
ОК, запустите эту программу. Вы должны получить (очень быстро) распечатку всех букв алфавита (потенциальных идентификаторов) сопровождаемых вопросительным знаком. Не очень захватывающе, но это только начало.
Конечно, вообще-то мы хотим видеть типы только тех переменных, которые были определены. Мы можем устранить другие добавив в DumpTable условие IF. Измените цикл следующим образом:
For i := 'A' to 'Z' do.
If ST[i] <> '?' then.
WriteLn(i, ' ', ST[i]);
Теперь запустите программу снова. Что вы получили?
Хорошо, это даже более скучно чем раньше! Сейчас вообще ничего не выводится, так как в данный момент ни одно из имен не было объявлено. Мы можем немного приправить результат вставив в основную программу несколько операторов, объявляющих несколько записей. Попробуйте такие:
ST['A'] := 'a';
ST['P'] := 'b';
ST['X'] := 'c';
На этот раз, когда вы запустите программу, вы должны получить распечатку, показывающую, что таблица идентификаторов работает правильно.
ДОБАВЛЕНИЕ ЗАПИСЕЙ.
Конечно, заполнение таблицы напрямую - довольно плохая практика и она не сможет хорошо нам послужить в будущем. То, что нам нужно, это процедура, добавляющая записи в таблицу. В то же самое время мы знаем, что нам будет необходимо тестировать таблицу для проверки, что мы не объявляем повторно переменную, которая уже используется (что легко может случиться при наличии всего 26 вариантов!). Для поддержки всего это введите следующие новые процедуры:
Code: { Report Type of a Variable }. Function TypeOf(N: char): char; Begin. TypeOf := ST[N]; End; { Report if a Variable is in the Table }. Function InTable(N: char): boolean; Begin. InTable := TypeOf(N) <> '?'; End; { Check for a Duplicate Variable Name }. Procedure CheckDup(N: char); Begin. If InTable(N) then Abort('Duplicate Name ' + N); End; { Add Entry to Table }. Procedure AddEntry(N, T: char); Begin. CheckDup(N); ST[N] := T; End;
Теперь измените три строки в основной программе следующим образом:
AddEntry('A', 'a');
AddEntry('P', 'b');
AddEntry('X', 'c');
И запустите программу снова. Работает? Тогда у нас есть подпрограммы таблицы идентификаторов, необходимые для поддержки нашей работы с типами. В следующем разделе мы начнем их использовать на практике.
РАСПРЕДЕЛЕНИЕ ПАМЯТИ.
В других программах, подобных этой, включая сам компилятор TINY, мы уже обращались к вопросу объявления глобальных переменных и кода, генерируемого для них. Давайте создадим здесь урезанную версию "компилятора", чья единственная функция - позволить нам объявлять переменные. Помните, синтаксис для объявления:
<data decl> ::= VAR <identifier>
Снова, мы можем вытащить массу кода из предыдущих программ. Следующий код - это урезанные версии тех процедур. Они значительно упрощены, так как я удалил такие тонкости как списки переменных и инициализаторы. Обратите внимание, что в процедуре Alloc новый вызов AddEntry будет также заботиться о проверке двойных объявлений:
Code: { Allocate Storage for a Variable }. Procedure Alloc(N: char); Begin. AddEntry(N, 'v'); WriteLn(N, ':', TAB, 'DC 0'); End; { Parse and Translate a Data Declaration }. Procedure Decl; Var Name: char; Begin. Match('v'); Alloc(GetName); End; { Parse and Translate Global Declarations }. Procedure TopDecls; Begin. While Look <> '.' do begin. Case Look of. 'v': Decl; Else Abort('Unrecognized Keyword ' + Look); End; Fin; End; End;
Теперь, в основной программе добавьте вызов TopDecl и запустите программу. Попробуйте распределить несколько переменных и обратите внимание на полученный сгенерированный код. Для вас это пройденный этап, поэтому результат должен выглядеть знакомым. Заметьте из кода для TopDecls что программа завершается точкой.
Пока вы здесь, попробуйте объявить две переменные с одинаковыми именами и проверьте что синтаксический анализатор отлавливает ошибку.
ОБЪЯВЛЕНИЕ ТИПОВ.
Распределение памяти различных размеров не сложнее чем изменение процедуры TopDecl для распознавания более чем одного ключевого слова. Здесь необходимо принять ряд решений, с точки зрения того, каков должен быть синтаксис и т.п., но сейчас я собираюсь отложить все эти вопросы и просто объявить не подлежащий утверждению указ что наш синтаксис будет таким:
<data decl> ::= <typename> <identifier>
Где:
<typename> ::= BYTE | WORD | LONG.
(По удивительному совпадению, первые буквы этих наименований оказались те же самыми что и спецификации длины ассемблерного кода 68000, так что такой выбор сэкономит нам немного работы.).
Мы можем создать код, который позаботится об этих объявлениях, внеся всего лишь небольшие изменения. Обратите внимание, что в подпрограммах, показанных ниже, я отделил генерацию код в Alloc от логической части. Это соответствует нашему желанию изолировать машинно-зависимую часть компилятора.
Code: { Generate Code for Allocation of a Variable }. Procedure AllocVar(N, T: char); Begin. WriteLn(N, ':', TAB, 'DC.', T, ' 0'); End; { Allocate Storage for a Variable }. Procedure Alloc(N, T: char); Begin. AddEntry(N, T); AllocVar(N, T); End; { Parse and Translate a Data Declaration }. Procedure Decl; Var Typ: char; Begin. Typ := GetName; Alloc(GetName, Typ); End; { Parse and Translate Global Declarations }. Procedure TopDecls; Begin. While Look <> '.' do begin. Case Look of. 'b', 'w', 'l': Decl; Else Abort('Unrecognized Keyword ' + Look); End; Fin; End; End;
Внесите показанные изменения в эти процедуры и испытайте программу. Используйте одиночные символы "b", "w" и "l" как ключевые слова (сейчас они должны быть в нижнем регистре). Вы увидите, что в каждом случае мы выделяем память соответствующего объема. Обратите внимание, глядя на дамп таблицы идентификаторов, что размеры также сохранены для использования позже. Какого использования? Хорошо, это тема остальной части этой главы.
ПРИСВАИВАНИЯ.
Теперь, когда мы можем объявлять переменные различных размеров, очевидно что мы должны иметь возможность что-то с ними делать. На первый раз, давайте просто попробуем загружать их в наш рабочий регистр D0. Имеет смысл использовать ту же самую идею, которую мы использовали для Alloc, т.е. сделаем процедуру загрузки, которая может загружать переменные нескольких размеров. Нам также необходимо продолжать изолировать машинно-зависимое содержимое. Процедура загрузки выглядит так:
Code: { Load a Variable to Primary Register }. Procedure LoadVar(Name, Typ: char); Begin. Move(Typ, Name + '(PC)', 'D0'); End;
По крайней мере для 68000, многие команды оказываются командами MOVE. Было бы полезно создать отдельный генератор кода только для этих инструкций и затем вызывать его когда необходимо:
Code: { Generate a Move Instruction }. Procedure Move(Size: char; Source, Dest: String); begin EmitLn('MOVE.' + Size + ' ' + Source + ',' + Dest); end;
Обратите внимание, что эти две подпрограммы - строго генераторы кода; они не имеют проверки ошибок и другой логики. Чтобы завершить картинку, нам необходим еще один программный уровень, который предоставляет эти функции.
Прежде всего, мы должны удостовериться, что типы, с которыми мы работаем - загружаемого типа. Это звучит как работа для другого распознавателя:
Code: { Recognize a Legal Variable Type }. Function IsVarType(c: char): boolean; Begin. IsVarType := c in ['B', 'W', 'L']; End;
Затем, было бы хорошо иметь подпрограмму, которая извлечет тип переменной из таблицы идентификаторов в то же время проверяя его на допустимость:
Code: { Get a Variable Type from the Symbol Table }. Function VarType(Name: char): char; Var Typ: char; Begin. Typ := TypeOf(Name); If not IsVarType(Typ) then Abort('Identifier ' + Name + ' is not a variable'); VarType := Typ; End;
Вооруженная этими инструментами, процедура, выполняющая загрузку переменной, становится тривиальной:
{ Load a Variable to the Primary Register }.
Procedure Load(Name: char); begin LoadVar(Name, VarType(Name)); end;
(Примечание для обеспокоившихся: я знаю, знаю, все это очень неэффективно. В промышленной программы мы, возможно, предприняли бы шаги чтобы избежать такого глубокого вложения вызовов процедур. Не волнуйтесь об этом. Это упражнение, помните? Более важно сделать его правильно и понять его, чем получить неправильный ответ но быстро. Если вы закончите свой компилятор и обнаружите, что вы несчастны от его быстродействия, вы вольны вернуться и доработать код для более быстрой работы).
Было бы хорошей идеей протестировать программу сейчас. Так как мы пока не имеем процедуры для работы с операциями присваивания, я просто добавил строки:
Load('A');
Load('B');
Load('C');
Load('X');
В основную программу. Таким образом, после того, как раздел объявления завершен, они будут выполнены чтобы генерировать код для загрузки. Вы можете поиграть с различными комбинациями объявлений чтобы посмотреть как обрабатываются ошибки.
Я уверен, что вы не будете удивлены, узнав, что сохранение переменных во многом подобно их загрузке. Необходимые процедуры показаны дальше:
Code: { Store Primary to Variable }. Procedure StoreVar(Name, Typ: char); Begin. EmitLn('LEA ' + Name + '(PC),A0'); Move(Typ, 'D0', '(A0)'); End; { Store a Variable from the Primary Register }. Procedure Store(Name: char); Begin. StoreVar(Name, VarType(Name)); End;
Вы можете проверить их таким же образом, что и загрузку.
Теперь, конечно, достаточно легко использовать их для обработки операций присваивания. Что мы сделаем - создадим специальную версию процедуры Block, которая поддерживает только операции присваивания, а также специальную версию Expression, которая поддерживает в качестве допустимых выражений только одиночные переменные. Вот они:
Code: { Parse and Translate an Expression }. Procedure Expression; Var Name: char; Begin. Load(GetName); End; { Parse and Translate an Assignment Statement }. Procedure Assignment; Var Name: char; Begin. Name := GetName; Match('='); Expression; Store(Name); End; { Parse and Translate a Block of Statements }. Procedure Block; Begin. While Look <> '.' do begin. Assignment; Fin; End; End;
(Стоит заметить, что новые процедуры, которые позволяют нам манипулировать типами, даже проще и яснее чем те, что мы видели ранее. Это в основном благодаря нашим усилиям по изоляции подпрограмм генерации кода.).
Есть одна небольшая назойливая проблема. Прежде мы использовали завершающую точку Паскаля чтобы выбраться из процедуры TopDecl. Теперь это неправильный символ... он использован для завершения Block. В предыдущих программах мы использовали для выхода символ BEGIN (сокращенно "b"). Но он теперь используется как символ типа.
Решение, хотя и является отчасти клуджем, достаточно простое. Для обозначения BEGIN мы будем использовать 'B' в верхнем регистре. Так что измените символ в цикле WHILE внутри TopDecl с "." на "B" и все будет прекрасно.
Теперь мы можем завершить задачу, изменив основную программу следующим образом:
Code: { Main Program }. Begin. Init; TopDecls; Match('B'); Fin; Block; DumpTable; End.
(Обратите внимание, что я должен был расставить несколько обращений к Fin чтобы избежать проблем переносов строк.).
ОК, запустите эту программу. Попробуйте ввести:
Ba { byte a } *** НЕ НАБИРАЙТЕ КОММЕНТАРИИ!!! ***
Wb { word b } lc { long c } B { begin } a=a a=b a=c b=a b=b b=c c=a c=b c=c.
.
Для каждого объявления вы должны получить сгенерированный код, распределяющий память. Для каждого присваивания вы должны получить код который загружает переменную корректного размера и сохраняет ее, также корректного размера.
Есть только одна небольшая проблема: сгенерированный код неправильный!
Взгляните на код для a=c:
MOVE.L C(PC),D0.
LEA A(PC),A0.
MOVE.B D0,(A0).
Этот код корректный. Он приведет к сохранению младших восьми бит C в A, что является приемлемым поведением. Это почти все, что мы можем ожидать.
Но теперь, взгляните на противоположный случай. Для c=a генерируется такой код:
MOVE.B A(PC),D0.
LEA C(PC),A0.
MOVE.L D0,(A0).
Это не правильно. Он приведет к сохранению байтовой переменной A в младших восьми битах D0. Согласно правилам для процессора 68000 старшие 24 бита останутся неизменными. Это означаем, что когда мы сохраняем все 32 бита в C, любой мусор, который был в этих старших разрядах, также будет сохранен. Нехорошо.
То, с чем мы сейчас столкнулись, называется проблемой преобразования типов или приведением.
Прежде, чем мы сделаем что-либо с переменными различных типов, даже если это просто их копирование, мы должны быть готовы встретиться с этой проблемой. Это не самая простая часть компилятора. Большинство ошибок, которые я видел в промышленных компиляторах, имели отношение к ошибкам преобразования типов для некоторой неизвестной комбинации аргументов. Как обычно, существует компромисс между сложностью компилятора и потенциальным качеством сгенерированного кода, и, как обычно, мы выберем путь, который сохранит компилятор простым. Я думаю вы найдете, что с таким подходом мы можем удерживать потенциальную сложность под достаточным контролем.
ТРУСЛИВЫЙ ВЫХОД.
Прежде, чем мы заберемся в детали (и потенциальную сложность) преобразования типов, я хотел бы, чтобы вы видели, что существует один супер простой способ решения проблемы: просто переводить каждую переменную в длинное целое во время загрузки!
Для этого достаточно добавить всего одну строку в LoadVar, хотя, если мы не собираемся полностью игнорировать эффективность, она должна ограничиваться проверкой IF. Вот измененная версия:
Code: { Load a Variable to Primary Register }. Procedure LoadVar(Name, Typ: char); Begin. If Typ <> 'L' then. EmitLn('CLR.L D0'); Move(Typ, Name + '(PC)', 'D0'); End;
(Обратите внимание, что StoreVar не нуждается в подобном изменении).
Если вы выполните некоторые тесты с этой новой версией, вы обнаружите, что теперь все работает правильно, хотя иногда неэффективно. К примеру, рассмотрим случай a=b (для тех же самых объявлений, что показаны выше). Теперь сгенерированный код становится:
CLR.L D0.
MOVE.W B(PC),D0.
LEA A(PC),A0.
MOVE.B D0,(A0).
В этом случае CLR оказывается ненужной, так как результат помещается в байтовую переменную. Небольшая доработка помогла бы нам улучшить его. Однако, все это не так уж плохо, и это типичного рода неэффективность, которую мы видели прежде в нехитрых компиляторах.
Я должен подчеркнуть, что устанавливая старшие разряды в нуль, мы фактически обрабатываем числа как целые числа без знака. Если вместо этого мы хотим обрабатывать их как целые числа со знаком (более вероятный случай) мы должны делать расширение знака после загрузки. Просто для того, чтобы обернуть эту часть дискуссии милой красной ленточкой, давайте изменим LoadVar как показано ниже:
Code: { Load a Variable to Primary Register }. Procedure LoadVar(Name, Typ: char); Begin. If Typ = 'B' then. EmitLn('CLR.L D0'); Move(Typ, Name + '(PC)', 'D0'); If Typ = 'W' then. EmitLn('EXT.L D0'); End;
В этой версии байт обрабатывается как без-знаковое число (как в Паскале и Си) в то время как слово обрабатывается как знаковое.
БОЛЕЕ ПРИЕМЛЕМОЕ РЕШЕНИЕ.
Как мы видели, перевод каждой переменной в длинное слово пока она находится в памяти решает проблему, но это едва ли может быть названо эффективным и, возможно, не было бы приемлемым даже для тех из нас, кто требует не обращать внимания на эффективность. Это означает, что все арифметические операции будут выполняться с 32-битной точностью, что удвоит время выполнения для большинства операций и сделает его еще больше для умножения и деления. Для этих операций мы должны были бы вызывать подпрограммы, даже если данные были бы байтом или словом. Все это слишком походит на уловку, так как уводит нас от всех настоящих проблем.
ОК, значит это решение плохое. Есть ли еще относительно простой способ получить преобразование данных? Можем ли мы все еще сохранять простоту?
Да, действительно. Все, что нам нужно сделать - выполнить преобразование с другого конца... т.е. мы выполняем преобразование на выходе, когда данные сохраняются, а не на входе.
Но запомните, часть присваивания, отвечающая за хранение, в значительной степени независима от загрузки данных, о которой заботится процедура Expression. Вообще, выражение может быть произвольно сложным, поэтому как может процедура Assignment знать, какой тип данных оставлен в регистре D0?
Снова, ответ прост: Мы просто спросим об этом процедуру Expression! Ответ может быть возвращен как значение функции.
Все это требует изменения некоторых процедур, но эти изменения, как и сам метод, совсем простые. Прежде всего, так как мы не требуем чтобы LoadVar выполнял всю работу по преобразованию, давайте возвратимся к простой версии:
Code: { Load a Variable to Primary Register }. Procedure LoadVar(Name, Typ: char); Begin. Move(Typ, Name + '(PC)', 'D0'); End;
Затем, давайте добавим новую процедуру, которая будет выполнять преобразование из одного типа в другой:
Code: { Convert a Data Item from One Type to Another }. Procedure Convert(Source, Dest: char); Begin. If Source <> Dest then begin. If Source = 'B' then. EmitLn('AND.W #$FF,D0'); If Dest = 'L' then. EmitLn('EXT.L D0'); End; End;
Затем, мы должны реализовать логику, требуемую для загрузки и сохранения переменной любого типа. Вот подпрограммы для этого:
Code: { Load a Variable to the Primary Register }. Function Load(Name: char): char; Var Typ : char; Begin. Typ := VarType(Name); LoadVar(Name, Typ); Load := Typ; End; { Store a Variable from the Primary Register }. Procedure Store(Name, T1: char); Var T2: char; Begin. T2 := VarType(Name); Convert(T1, T2); StoreVar(Name, T2); End;
Обратите внимание, что Load является функцией, которая не только выдает код для загрузки, но также возвращает тип переменной. Таким образом, мы всегда знаем, с каким типом данных мы работаем. Когда мы выполняем Store, мы передаем ей текущий тип переменной в D0. Так как Store также знает тип переменной назначения, она может выполнить преобразование необходимым образом.
Вооруженная всеми этими новыми подпрограммами, реализация нашего элементарного присваивания по существу тривиальна. Процедура Expression теперь становится функцией возвращающей тип выражения в процедуру Assignment:
Code: { Parse and Translate an Expression }. Function Expression: char; Begin. Expression := Load(GetName); End; { Parse and Translate an Assignment Statement }. Procedure Assignment; Var Name: char; Begin. Name := GetName; Match('='); Store(Name, Expression); End;
Снова, заметьте как невероятно просты эти две подпрограммы. Мы изолировали всю логику типа в Load и Store и хитрость с передачей типа делает остальную работу чрезвычайно простой. Конечно, все это для нашего специального, тривиального случая с Expression. Естественно, для общего случая это будет более сложно. Но теперь вы смотрите на финальную версию процедуры Assignment!
Все это выглядит как очень простое и ясное решение, и действительно это так. Откомпилируйте эту программу и выполните те же самые тесты, что и ранее. Вы увидите, что все типы данных преобразованы правильно и здесь немного, если вообще есть, зря потраченных инструкций. Только преобразование "байт длинное слово" использует две инструкции когда можно было бы использовать одну, и мы могли бы легко изменить Convert для обработки этого случая.
Хотя мы в этом случае не рассматривали переменные без знака, я думаю вы можете видеть, что мы могли бы легко исправить процедуру Convert для работы и с этими типами. Это "оставлено как упражнение для студента".
ЛИТЕРАЛЬНЫЕ АРГУМЕНТЫ.
Зоркие читатели могли бы отметить, однако, что мы еще даже не имеем правильной формы простого показателя, потому что мы не разрешаем загрузку литеральных констант, только переменных. Давайте исправим это сейчас.
Для начала нам понадобится функция GetNum. Мы уже видели ее несколько версий, некоторые возвращают только одиночный символ, некоторые строку, а некоторые целое число. Та, которая нам здесь нужна будет возвращать длинное целое, так что она может обрабатывать все, что мы ей подбросим. Обратите внимание, что здесь не возвращается никакой информации о типах: GetNum не интересуется тем, как будет использоваться число:
Code: { Get a Number }. Function GetNum: LongInt; Var Val: LongInt; Begin. If not IsDigit(Look) then Expected('Integer'); Val := 0; While IsDigit(Look) do begin. Val := 10 * Val + Ord(Look) - Ord('0'); GetChar; End; GetNum := Val; SkipWhite; End;
Теперь, когда работаем с литералами, мы имеем одну небольшую проблему. С переменными мы знаем какого типа они должны быть потому что они были объявлены с таким типом. Мы не имеем такой информации о типе для литералов. Когда программист говорит "-1", означает ли это байт, слово или длинное слово? Мы не имеем никаких сведений. Очевидным способом было бы использование наиболее возможного типа, т.е. длинного слова. Но это плохая идея, потому что когда мы примемся за более сложные выражения, мы обнаружим, что это заставит каждое выражение, включающее литералы, также переводить в длинное.
Лучшим подходом было бы выбрать тип, основанный на значении литерала, как показано далее:
Code: { Load a Constant to the Primary Register }. Function LoadNum(N: LongInt): char; Var Typ : char; Begin. If abs(N) <= 127 then. Typ := 'B' Else if abs(N) <= 32767 then. Typ := 'W' Else Typ := 'L'; LoadConst(N, Typ); LoadNum := Typ; End;
(Я знаю, знаю, база числа не является в действительности симметричной. Вы можете хранить -128 в одиночном байте и -32768 в слове. Но это легко исправить и не стоит затраченного времени или дополнительной сложности возиться с этим сейчас. Стоящая мысль.).
Заметьте, что LoadNum вызывает новую версию подпрограммы генерации кода LoadConst, которая имеет дополнительный параметр для определения типа:
Code: { Load a Constant to the Primary Register }. Procedure LoadConst(N: LongInt; Typ: char); Var temp:string; Begin. Str(N, temp); Move(Typ, '#' + temp, 'D0'); End;
Теперь мы можем изменить процедуру Expression для использования двух возможных видов показателей:
Code: { Parse and Translate an Expression }. Function Expression: char; Begin. If IsAlpha(Look) then. Expression := Load(GetName). Else. Expression := LoadNum(GetNum); End;
(Вау, это, уверен, не причинило слишком большого вреда! Всего несколько дополнительных строк делают всю работу.).
ОК, соберите этот код в вашу программу и испытайте ее. Вы увидите, что она теперь работает и для переменных и для констант как допустимых выражений.
АДДИТИВНЫЕ ВЫРАЖЕНИЯ.
Если вы следовали за этой серией с самого начала, я уверен вы знаете, что будет дальше. Мы расширим форму выражения для поддержки сначала аддитивных выражений, затем мультипликативных, а затем общих выражений со скобками.
Хорошо, что мы уже имеем модель для работы с этими более сложными выражениями. Все, что мы должны сделать, это удостовериться, что все процедуры, вызываемые Expression, (Term, Factor и т.д.) всегда возвращают идентификатор типа. Если мы сделаем это, то структура программы едва ли вообще изменится.
Первый шаг прост: мы должны переименовать нашу существующую версию Expression в Term, как мы делали много раз раньше и создать новую версию Expression:
Code: { Parse and Translate an Expression }. Function Expression: char; Var Typ: char; Begin. If IsAddop(Look) then. Typ := Unop. Else. Typ := Term; While IsAddop(Look) do begin. Push(Typ); Case Look of. '+': Typ := Add(Typ); '-': Typ := Subtract(Typ); End; End; Expression := Typ; End;
Обратите внимание, как в этой подпрограмме каждый вызов процедуры стал вызовом функции и как локальная переменная Typ модифицируется при каждом проходе.
Обратите внимание также на новый вызов функции Unop, которая позволяет нам работать с ведущим унарным минусом. Это изменение не является необходимым... мы все еще можем использовать форму более похожую на ту, что мы использовали ранее. Я решил представить Unop как отдельную подпрограмму потому что позднее это позволит производить несколько лучший код, чем мы делали. Другими словами, я смотрю вперед на проблему оптимизации.
Для этой версии, тем не менее, мы сохраним тот же самый примитивный старый код, который делает новую подпрограмму тривиальной:
Code: { Process a Term with Leading Unary Operator }. Function Unop: char; Begin. Clear; Unop := 'W'; End;
Процедура Push - это подпрограмма генерации кода, которая теперь имеет параметр, указывающий тип:
Code: { Push Primary onto Stack }. Procedure Push(Size: char); Begin. Move(Size, 'D0', '-(SP)'); End;
Теперь давайте взглянем на функции Add и Subtract. В более старых версиях этих подпрограмм мы позволяем им вызывать подпрограммы генерации кода PopAdd и PopSub. Мы продолжим делать это, что делает сами функции чрезвычайно простыми:
Code: { Recognize and Translate an Add }. Function Add(T1: char): char; Begin. Match('+'); Add := PopAdd(T1, Term); End; { Recognize and Translate a Subtract }. Function Subtract(T1: char): char; Begin. Match('-'); Subtract := PopSub(T1, Term); End;
Но простота обманчива, поскольку мы переложили всю логику на PopAdd и PopSub, которые больше не являются просто подпрограммами генерации кода. Они также должны теперь заботиться о необходимых преобразованиях типов.
Какие это преобразования? Простые: оба аргумента должны иметь тот же самый размер и результат также такой размер. Меньший из двух параметров должен быть "приведен" до размера большего.
Но это представляет небольшую проблему. Если переводимый параметр - второй (т.е. в основном регистре D0) мы в отличной форме. Если же нет, мы в затруднении: мы не можем изменить размер данных, которые уже затолкнуты в стек.
Решение простое, но немного болезненное: мы должны отказаться от этих красивых инструкций "вытолкнуть данные и что-нибудь с ними сделать", заботливо предоставленных Motorola.
Альтернативой является назначение вторичного регистра, в качестве которого я выбрал R7. (Почему не R1? Потому, что для других регистров у меня есть планы на будущее.).
Первый шаг в этой новой структуре - представить процедуру Pop, аналогичную Push. Эта процедура будет всегда выталкивать верхний элемент стека в D7:
Code: { Pop Stack into Secondary Register }. Procedure Pop(Size: char); Begin. Move(Size, '(SP)+', 'D7'); End;
Общая идея состоит в том, что все "Pop-Op" подпрограммы могут вызывать ее. Когда это сделано, мы будем иметь оба операнда в регистрах, поэтому мы можем перевести любой нужный нам. Для работы процедуре Convert необходим другой аргумент, имя регистра:
Code: { Convert a Data Item from One Type to Another }. Procedure Convert(Source, Dest: char; Reg: String); Begin. If Source <> Dest then begin. If Source = 'B' then. EmitLn('AND.W #$FF,' + Reg); If Dest = 'L' then. EmitLn('EXT.L ' + Reg); End; End;
Следующая функция выполняет преобразование, но только если текущий тип T1 меньше по размеру, чем желаемый тип T2. Это функция, возвращающая конечный тип, позволяющий нам знать, что она решила:
Code: { Promote the Size of a Register Value }. Function Promote(T1, T2: char; Reg: string): char; Var Typ: char; Begin. Typ := T1; If T1 <> T2 then. If (T1 = 'B') or ((T1 = 'W') and (T2 = 'L')) then begin. Convert(T1, T2, Reg); Typ := T2; End; Promote := Typ; End;
Наконец, следующая функция приводит два регистра к одному типу:
Code: { Force both Arguments to Same Type }. Function SameType(T1, T2: char): char; Begin. T1 := Promote(T1, T2, 'D7'); SameType := Promote(T2, T1, 'D0'); End;
Эти новые подпрограммы дают нам заряд, необходимы нам чтобы разложить PopAdd и PopSub:
Code: {---------------------------------------------------------------} { Generate Code to Add Primary to the Stack }. Function PopAdd(T1, T2: char): char; Begin. Pop(T1); T2 := SameType(T1, T2); GenAdd(T2); PopAdd := T2; End; {---------------------------------------------------------------} { Generate Code to Subtract Primary from the Stack }. Function PopSub(T1, T2: char): char; Begin. Pop(T1); T2 := SameType(T1, T2); GenSub(T2); PopSub := T2; End;
После всех этих приготовлений, в конечном результате нет почти ничего кульминационного. Снова, вы можете видеть что логика совершенно проста. Все что делают эти две подпрограммы - выталкивают вершину стека в D7, приводят два операнда к одному размеру и затем генерируют код.
Обратите внимание на две новые подпрограммы генерации кода GenAdd и GenSub. Они являются остаточной формой оригинальных PopAdd и PopSub. Т.е. они являются чистыми генераторами кода, производящими сложение и вычитание регистров:
Code: { Add Top of Stack to Primary }. Procedure GenAdd(Size: char); Begin. EmitLn('ADD.' + Size + ' D7,D0'); End; {---------------------------------------------------------------} { Subtract Primary from Top of Stack }. Procedure GenSub(Size: char); Begin. EmitLn('SUB.' + Size + ' D7,D0'); EmitLn('NEG.' + Size + ' D0'); End;
ОК, я соглашусь с вами: я выдал вам множество подпрограмм с тех пор, как мы в последний раз протестировали код. Но вы должны признать, что каждая новая подпрограмма довольно проста и ясна. Если вам (как и мне) не нравится тестировать так много новых подпрограмм одновременно все в порядке. Вы можете заглушить подпрограммы типа Convert, Promote и SameType так как они не считывают входной поток. Вы не получите корректный код, конечно, но программа должна работать. Затем постепенно расширяйте их.
При тестировании программы не забудьте, что вы сначала должны объявить некоторые переменные а затем начать "тело" программы с "B" в верхнем регистре (для BEGIN). Вы должны обнаружить, что синтаксический анализатор обрабатывает любые аддитивные выражения. Как только все подпрограммы преобразования будет введены, вы должны увидеть, что генерируется правильный код и код для преобразования типов вставляется в нужных местах. Попробуйте смешивать переменные различных размеров а также литералы. Удостоверьтесь, что все работает правильно. Как обычно, хорошо было бы попробовать некоторые ошибочные выражения и посмотреть, как компилятор обрабатывает их.
ПОЧЕМУ ТАК МНОГО ПРОЦЕДУР?
К этому моменту вы можете подумать, что я зашел слишком далеко в смысле глубоко вложенных процедур. В этом несомненно есть большие накладные расходы. Но в моем безумии есть смысл. Как в случае с UnOp, я заглядываю вперед на время, когда мы захотим генерировать лучший код. С таким способом организации кода мы можем достичь этого без значительных изменений в программе Например, в случаях, где значение, помещенное в стек не должно преобразовываться, все же лучше использовать инструкцию "вытолкнуть и сложить". Если мы решим проверять такие случаи, мы можем включить дополнительные тесты в PopAdd и PopSub не изменяя что-либо еще.
МУЛЬТИПЛИКАТИВНЫЕ ВЫРАЖЕНИЯ.
Процедуры для работы с мультипликативными операторами почти такие же. Фактически, на первом уровне они почти идентичны, так что я просто покажу их здесь без особых фанфар. Первая - наша общая форма для Factor, которая включает подвыражения в скобках:
Code: { Parse and Translate a Factor }. Function Expression: char; Forward; Function Factor: char; Begin. If Look = '(' then begin. Match('('); Factor := Expression; Match(')'); End. Else if IsAlpha(Look) then. Factor := Load(GetName). Else. Factor := LoadNum(GetNum); End; { Recognize and Translate a Multiply }. Function Multiply(T1: char): char; Begin. Match('*'); Multiply := PopMul(T1, Factor); End; { Recognize and Translate a Divide }. Function Divide(T1: char): char; Begin. Match('/'); DIvide := PopDiv(T1, Factor); End; {---------------------------------------------------------------} { Parse and Translate a Math Term }. Function Term: char; Var Typ: char; Begin. Typ := Factor; While IsMulop(Look) do begin. Push(Typ); Case Look of. '*': Typ := Multiply(Typ); '/': Typ := Divide(Typ); End; End; Term := Typ; End;
Эти подпрограммы соответствуют аддитивным почти полностью. Как и прежде, сложность изолирована в PopMul и PopDiv. Если вам захочется протестировать программу прежде чем мы займемся ими, вы можете написать их пустые версии, аналогичные PopAdd и PopSub. И снова, код не будет корректным в данный момент, но синтаксический анализатор должен обрабатывать выражения произвольной сложности.
УМНОЖЕНИЕ.
Если вы убедились, что сам синтаксический анализатор работает правильно, мы должны выяснить, что необходимо сделать для генерации правильного кода. С этого места дела становятся немного труднее так как правила более сложные.
Давайте с начала возьмем случай умножения. Эта операция аналогична "addops" в том, что оба операнда должны быть одного и того же размера. Она отличается в трех важных отношениях:
· Тип произведения обычно не такой же как тип двух операндов. Для произведения двух слов мы получаем в результате длинное слово.
· 68000 не поддерживает умножение 32 x 32, так что необходим вызов подпрограммы для программного умножения.
· Он также не поддерживает умножение 8 x 8, поэтому байтовые операнды должны быть переведены до слова.
Действия, которые мы должны выполнить, лучше всего показывает следующая таблица:
T1. T2. B. W. L. B. Преобразовать D0 в W. Преобразовать D7 в W. MULS. Result = W. Преобразовать D0 в W. MULS. Result = L. Преобразовать D0 в L. JSR MUL32. Result = L. W. Преобразовать D7 в W. MULS. Result = L. MULS. Result = L. Преобразовать D0 в L. JSR MUL32. Result = L. L. Преобразовать D7 в L. JSR MUL32. Result = L. Преобразовать D7 в L. JSR MUL32. Result = L. JSR MUL32. Result = L.
Эта таблица показывает действия, предпринимаемые для каждой комбинации типов операндов. Есть три вещи, на которые необходимо обратить внимание: во-первых, мы предполагаем, что существует библиотечная подпрограмма MUL32, которая выполняет 32 x 32 умножение, оставляя 32-битное (не 64) произведение. Если в процессе этого происходит переполнение мы игнорируем его и возвращаем только младшие 32 бита.
Во-вторых, заметьте, что таблица симметрична. Наконец, обратите внимание, что произведение это всегда длинное слово, за исключением случая когда оба операнда байты. (Стоит заметить, между прочим, что это означает что результатом многих выражений будет длинное слово, нравится нам это или нет. Возможно идея перевода всех их заранее не была уж такой возмутительной, в конце концов!).
Теперь ясно, что мы должны будем генерировать различный код для 16-разрядного и 32-разрядного умножения. Для этого лучше всего иметь отдельные подпрограммы генерации кода для этих двух случаев:
Code: {---------------------------------------------------------------} { Multiply Top of Stack by Primary (Word) }. Procedure GenMult; Begin. EmitLn('MULS D7,D0'). End; {---------------------------------------------------------------} { Multiply Top of Stack by Primary (Long) }. Procedure GenLongMult; Begin. EmitLn('JSR MUL32'); End; {---------------------------------------------------------------}
Исследование кода ниже для PopMul должно убедить вас, что условия в таблице выполнены:
Code: { Generate Code to Multiply Primary by Stack }. Function PopMul(T1, T2: char): char; Var T: char; Begin. Pop(T1); T := SameType(T1, T2); Convert(T, 'W', 'D7'); Convert(T, 'W', 'D0'); If T = 'L' then. GenLongMult. Else. GenMult; If T = 'B' then. PopMul := 'W' Else. PopMul:= 'L'; End;
Как вы можете видеть, подпрограмма начинается совсем как PopAdd. Два аргумента приводятся к тому же самому типу. Два вызова Convert заботятся о случаях, когда оба операнда - байты. Сами данные переводятся до слова, но подпрограмма помнит тип чтобы назначать корректный тип результату. В заключение мы вызываем одну из двух подпрограмм генерации кода и затем назначаем тип результата. Не слишком сложно, действительно.
Я полагаю, что сейчас вы уже тестируете программу. Попробуйте все комбинации размеров операндов.
ДЕЛЕНИЕ.
Случай с делением совсем не так симметричен. У меня также есть для вас некоторые плохие новости:
Все современные 16-разрядные процессоры поддерживают целочисленное деление. Спецификации изготовителей описывают эту операцию как 32 x 16 бит деление, означающее, что вы можете разделить 32-разрядное делимое на 16-разрядный делитель. Вот плохая новость:
Они вам лгут!!!
Если вы не верите в это, попробуйте разделить любое большое 32-разрядное число (это означает, что оно имеет ненулевые биты в старших 16 разрядах) на целое число 1. Вы гарантированно получите исключение переполнения.
Проблема состоит в том, что эта команда в действительности требует, чтобы получаемое частное вписывалось в 16-разрядный результат. Этого не случится, если делитель достаточно большой. Когда любое число делится на единицу, частное будет конечно тем же самым, что и делимое.
С начала времен (ну во всяком случае компьютерных) архитекторы ЦПУ предусматривали этот маленький подводный камень в схеме деления. Это обеспечивает некоторую симметрию, так как это своего рода инверсия способа каким работает умножение. Но так как единица - это совершенно допустимое (и довольно частое) число для использования в качестве делителя, делению, реализованному аппаратно, требуется некоторая помощь от программистов.
Подразумевает следующее:
· Тип частного всегда должен быть того же самого типа, что и делимое. Он независим от делителя.
· Несмотря на то, что ЦПУ поддерживает деление длинного слова, аппаратно предоставленной инструкции можно доверить только делимые байт и слово. Для делимых типа длинное слово нам необходима другая библиотечная подпрограмма, которая может возвращать длинный результат.
Это похоже на работу для другой таблицы, для суммирования требуемых действий:
T1. T2. B. W. L. B. Преобразовать D0 в W. Преобразовать D7 в L. DIVS. Result = B. Преобразовать D0 в W. Преобразовать D7 в L. DIVS. Result = W. Преобразовать D0 в L. JSR DIV32. Result = L. W. Преобразовать D7 в L. DIVS. Result = B. Преобразовать D7 в L. DIVS. Result = W. Преобразовать D0 в L. JSR DIV32. Result = L. L. Преобразовать D7 в L. JSR DIV32. Result = B. Преобразовать D7 в L. JSR DIV32. Result = W. JSR DIV32. Result = L.
(Вы можете задаться вопросом, почему необходимо выполнять 32-разрядное деление, когда делимое, скажем, всего лишь байт. Так как число битов в результате может быть только столько, сколько и в делимом, зачем беспокоиться? Причина в том, что если делитель - длинное слово и в нем есть какие-либо установленные старшие разряды, результат деления должен быть равен нулю. Мы не смогли бы получить его, если мы используем только младшее слово делителя).
Следующий код предоставляет корректную функцию для PopDiv:
Code: { Generate Code to Divide Stack by the Primary }. Function PopDiv(T1, T2: char): char; Begin. Pop(T1); Convert(T1, 'L', 'D7'); If (T1 = 'L') or (T2 = 'L') then begin. Convert(T2, 'L', 'D0'); GenLongDiv; PopDiv := 'L'; End. Else begin. Convert(T2, 'W', 'D0'); GenDiv; PopDiv := T1; End; End; {---------------------------------------------------------------} Две подпрограммы генерации кода: {---------------------------------------------------------------} { Divide Top of Stack by Primary (Word) }. Procedure GenDiv; Begin. EmitLn('DIVS D0,D7'); Move('W', 'D7', 'D0'); End; {---------------------------------------------------------------} { Divide Top of Stack by Primary (Long) }. Procedure GenLongDiv; Begin. EmitLn('JSR DIV32'); End;
Обратите внимание, мы предполагаем, что DIV32 оставляет результат (длинное слово) в D0.
ОК, установите новые процедуры деления. Сейчас у вас должна быть возможность генерировать код для любого вида арифметических выражений. Погоняйте ее!
ЗАВЕРШЕНИЕ.
Наконец-то, в этой главе мы узнали как работать с переменными (и литералами) различных типов. Как вы можете видеть, это не было слишком сложно. Фактически, в каком-то отношении большая часть кода выглядит даже еще проще, чем это было в более ранних программах. Только операторы умножения и деления требуют небольших размышлений и планирования.
Основная идея, которая облегчила нам жизнь, - идея преобразования процедур типа Expression в функции, возвращающие тип результата. Как только это было сделано, мы смогли сохранить ту же самую общую структуру компилятора.
Я не буду притворяться, что мы охватили каждый одиночный аспект этой проблемы. Я удобно проигнорировал без знаковую арифметику. Из того, что мы сделали, я думаю вы можете видеть, что их включение не добавляет никаких дополнительных проблем, просто дополнительные проверки.
Я так же игнорировал логические операторы And, Or и т.д. Оказывается, их довольно легко обрабатывать. Все логические операторы - побитовые операции, так что они симметричны и, следовательно, работают в том же самом режиме, что и PopAdd. Однако, имеется одно отличие: если необходимо расширить длину слова для логической переменной, расширение должно быть сделано как число без знака. Числа с плавающей точкой, снова, являются простыми для обработки... просто еще несколько процедур, которые будут добавлены в run-time библиотеку или, возможно, инструкции для математического сопроцессора.
Возможно более важно, что я также отделил проблему контроля соответствия типов, в противоположность преобразованию. Другими словами, мы разрешили операции между переменными всех комбинаций типов. Вообще, это не будет верным... конечно вы не захотите прибавить целое число, например, к строке. Большинство языков также не позволят вам смешивать символьные и целочисленные переменные.
Снова, в действительности в этом случае нет никаких новых проблем для рассмотрения. Мы уже проверяем типы двух операндов... в основном эти проверки выполняются в процедурах типа SameType. Довольно просто включить вызов обработчика ошибок если типы двух операндов несовместимы.
В общем случае мы можем рассматривать каждый одиночный оператор как обрабатываемый отдельной процедурой, в зависимости от типа двух операндов. Это просто, хотя и утомительно, реализовать просто создав таблицу переходов с типами операндов как индексами. В Паскале эквивалентная операция включала бы вложенные операторы Case. Некоторые из вызываемых процедур могли бы тогда быть простыми подпрограммами обработки ошибок, в то время как другие могли бы выполнять любые виды преобразований, необходимые нам. При добавлении нами типов, число процедур будет возрастать в геометрической прогрессии, но это все равно не неприемлемо большое число процедур.
Здесь же мы свернули такую таблицу переходов в гораздо меньшее количество процедур, просто используя симметрию и другие упрощающие правила.
ПРИВОДИТЬ ИЛИ НЕ ПРИВОДИТЬ.
В случае, если до вас еще не дошло, уверен дойдет, что TINY и KISS возможно не будут строго типизированными языками, так как я разрешил автоматическое смешивание и преобразование почти любых типов. Что поднимает следующий вопрос:
Это действительно то, что мы хотим сделать?
Ответ зависит от того, какого рода язык вам нужен и как вы хотели чтобы он себя вел. Мы не обращались к проблеме того, когда разрешить или когда запретить использование операций, включающих различные типы данных. Другими словами, какова должна быть семантика нашего компилятора? Хотим ли мы выполнять автоматическое преобразование типов для всех случаев, в некоторых случаях или не выполнять совсем?
Давайте приостановимся здесь, чтобы подумать об этом немного больше. В этом нам поможет небольшой исторический обзор.
Fortran II поддерживал только два простых типа данных: Integer и Real. Он разрешал неявное преобразование типов между real и integer типами во время присваивания, но не в выражениях. Все элементы данных (включая литеральные константы) справа оператора присваивания должны были быть одинакового типа. Это довольно сильно облегчало дела... гораздо проще, чем то, что мы делали здесь.
Это было изменено в Fortran IV для поддержки "смешанной" арифметики. Если выражение имело любые real элементы, все они преобразовывались в real и само выражение было real. Для полноты, предоставлялись функции для явного преобразования из одного типа в другой, чтобы вы могли привести выражение в любой тип.
Это вело к двум вещам: код, который был проще для написания и код, который был менее эффективен. Из-за это неаккуратные программисты должны были писать выражения с простыми константами типа 0 и 1, которые компилятор должен был покорно компилировать для преобразования во время выполнения. Однако, система работала довольно хорошо, что показывало что неявное преобразование типов - Хорошая Вещь.
Си - также слабо типизированный язык, хотя он поддерживает большее количество типов. C не будет жаловаться, если вы например попытаетесь прибавить символ к целому числу. Частично, в этом помогает соглашение Си о переводе каждого символа в число когда оно загружается или передается в списке параметров. Это совсем немного упрощает преобразование. Фактически, в подмножестве компиляторов Си, которые не поддерживают длинные или с плавающей точкой числа мы возвращаемся к нашей первой нехитрой попытке: каждая переменная получает одинаковое представление как только загружается в регистр. Жизнь становится значительно проще!
Предельным языком в направлении автоматического преобразования типов является PL/I. Этот язык поддерживает большое количество типов данных, и вы можете свободно смешивать их все. Если неявное преобразование Fortran казалось хорошим, то таковое в PL/I было бы Небесами, но оно скорее оказалось Адом! Проблема состояла в том, что с таким большим количеством типов данных должно существовать большое количество различных преобразований и, соответственно, большое количество правил того, как смешиваемые операнды должны преобразовываться. Эти правила стали настолько сложными, что никто не мог запомнить какие они! Множество ошибок в программах на PL/I имели отношение к непредвиденным и нежелательным преобразованиям типов. Слишком хорошо тоже нехорошо!
Паскаль, с другой стороны, является языком, который "строго типизирован", что означает, что вы вообще не можете смешивать типы даже если они отличаются только именем, хотя они и имеют тот же самый базовый тип! Никлаус Вирт сделал Паскаль строго типизированным чтобы помочь программисту избежать проблем и эти ограничения действительно защитили многих программистов от самих себя, потому что компилятор предохранял его от глупых ошибок. Лучше находить ошибки при компиляции, чем на этапе отладки. Те же самые ограничения могут также вызвать расстройства когда вам действительно нужно смешивать типы и они заставляют бывших C-программистов лезть на стену.
Даже в этом случае, Паскаль разрешает некоторые неявные преобразования. Вы можете присвоить целое значение вещественному. Вы можете также смешивать целые и вещественные типы в выражениях типа Real. Целые числа будут автоматически приведены к вещественным, как и в Fortran. (и с теми же самыми скрытыми накладными расходами во время выполнения).
Вы не можете, однако, преобразовывать наоборот из вещественного в целое без применения явной функции преобразования Trunc. Теория здесь в том, что так как числовое значение вещественного числа обязательно будет изменено при преобразовании (дробная часть будет потеряна), это не должно быть сделано в "секрете" от вас.
В духе строгого контроля типов Паскаль не позволит вам смешивать Char и Integer переменные без применения явных функций приведения Chr и Ord. Turbo Pascal также включает типы Byte, Word и LongInt. Первые два в основном то же самое, что и без знаковое целое. В Turbo они могут быть свободно смешаны с переменными типа Integer и Turbo автоматически выполнит преобразование. Однако существуют проверки времени выполнения, предохраняющие вас от переполнения или иного способа получения неправильного ответа. Заметьте, что вы все еще не можете смешивать типы Byte и Char, даже при том, что они имеют то же самое внутреннее представление.
Пределом среди строго типизированных языков является Ada, который не разрешает никаких неявных преобразований типов вообще, и также не разрешает смешанную арифметику. Позиция Jean Ichbiah в том, что преобразования стоят времени выполнения и вам нельзя позволить платить такую цену на скрытый манер. Вынуждая программиста явно запрашивать преобразование типов вы делаете более очевидным то, что здесь могут быть вовлечены затраты.
Я использовал другой язык со строгим контролем типов, небольшой восхитительный язык, названный Whimsical, от Джона Спрея. Хотя Whimsical предназначен быть языком системного программирования, он также требует каждый раз явного преобразования. В нем никогда не выполняются никакие автоматические преобразования, даже те, которые поддерживаются в Паскале.
Такой подход имеет некоторые преимущества: компилятор никогда не должен предполагать, что делать: программист всегда говорит ему точно, что он хочет. В результате, появляется почти однозначное соответствие между исходным кодом и компилированным кодом, и компилятор Джона производил очень компактный код.
С другой стороны, я иногда находил явные преобразования болезненными. Если я хочу, например, прибавить единицу к символу, или сложить ее с маской, необходимо выполнить массу преобразований. Если я сделаю это неправильно единственным сообщением об ошибке будет "Типы не совместимы". Как это случается, специфическая реализация Джоном этого языка в его компиляторе не сообщает вам точно, какие типы несовместимы... он только сообщает вам, в какой строке произошла ошибка.
Я должен признать, что большинство моих ошибок с этим компилятором были ошибками такого типа, и я потратил много времени с компилятором Whimsical, пытаясь всего лишь выяснить в каком месте строки я ее допустил. Единственный реальный способ исправить ошибку это продолжать исправления до тех пор, пока что-нибудь не заработает.
Так что мы должны сделать в TINY и KISS? Для первого я имею ответ: TINY будет поддерживать только типы Char и Integer и мы будем использовать прием C непосредственно переводя Char в Integer. Это означает, что компилятор TINY будет значительно проще, чем то, что мы уже сделали. Необходимость преобразования типов в выражении спорна, так как ни одно из них не требуется! Так как длинное слово не будет поддерживаться, нам также будут не нужны подпрограммы MUL32 и DIV32, ни логики для выяснения когда их вызывать. Мне это нравится!
KISS, с другой стороны будет поддерживать тип Long.
Должен ли он поддерживать и знаковую и без знаковую арифметику? Ради простоты я предпочел бы нет. Это добавляет совсем немного сложности в преобразования типов. Даже Никлаус Вирт удалили без знаковые числа (Cardinal) из его нового языка Оберон, с тем аргументом, что 32-разрядного целого числа в любом случае должно быть достаточно всем.
Но KISS предполагается быть языком системного программирования, что означает, что у нас должна быть возможность выполнять любые действия, которые могут быть выполнены на ассемблере. Так как 68000 поддерживает обе разновидности целых чисел, я полагаю что KISS тоже должен. Мы видели, что логические операции должны быть способны расширять целые числа без знаковым способом, поэтому процедуры без знакового преобразования нужны в любом случае.
ЗАКЛЮЧЕНИЕ.
На этом завершается наш урок по преобразованиям типов. Жаль, что вы должны были так долго ждать его, но, надеюсь, вы чувствуете, что он того стоил.
В нескольких следующих главах мы расширим простые типы, включив поддержку массивов и указателей и посмотрим, что делать со строками. Это позволит довольно успешно завершить основную часть этой серии. После этого я дам вам новые версии компиляторов TINY и KISS, а затем мы начнем рассматривать вопросы оптимизации.
| Тип диаграммы |
Тип диаграммы
Тип диаграммы определяет, каким образом отображается информация: в виде плоских или объемных фигур или графиков, а также сам вид этих фигур. Существует около 70 типов диаграмм, и чтобы выбрать один из них, используется метод ApplyCustomType. В качестве аргумента этого метода используется константа из списка (см. приложение www.kornjakov.ru/st2_6.zip). В Delphi выбор типа диаграммы можно реализовать, используя функцию SetChartType.
Code: Function SetChartType (Name:variant;ChartType:integer):boolean; Begin. SetChartType:=true; Try. E.Charts.Item[name].ApplyCustomType(ChartType:=ChartType); Except. SetChartType:=false; End; End;
| Управление прокруткой Memo. |
У меня имеется компонент TMemo, и мне необходимо автоматически "тормозить" программным способом его прокрутку при добавлении новой строки Memo.Lines.Add(Строка).
| Управление mIRC при помощи DDE. |
Code: Uses. DdeMan; Procedure mIRCDDE(Service, Topic, Cmd: string); Var. DDE: TDDEClientConv; Begin. Try. DDE := TDDEClientConv.Create(nil); DDE.SetLink(Service, Topic); DDE.OpenLink; DDE.PokeData(Topic, PChar(Cmd)); Finally. DDE.Free; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. MIRCDDE('mIRC', 'COMMAND', '/say Hallo von SwissDelphiCenter.ch'); End;
| Управление свойством Font через сервер автоматизации |
Данный документ предназначен главным образом тем программистам, кто использует OLE/COM и хочет встроить объект Font (типа Delphi-го TFont) в свой сервер автоматизации. Интерфейс IFontDisp для COM будет иметь ту же функциональность, что и Delphi-ий TFont. Например, если у вас имеется клиент автоматизации, содержащий объект со свойством Font, и в сервере автоматизации для изменения атрибутов текста вы хотите иметь те же методы (наприр, имя шрифта, жирное или наклонное начертание). Для хранения и управления шрифтом сервер автоматизации может применять реализацию интерфейса IFontDisp.
| Управление Program Manager в Win95 с помощью DDE. |
Для управления программными группами в Program Manager с помощью DDE мною был использован следующий модуль. За основу был взят код Steve Texeira (sp) из руководства Dephi Developers Guide.
Управление Word-ом из Дельфи.
| Управление Word-ом из Дельфи |
Здесь мы рассмотрим пример того, как управлять объектами Word-а (Excel - аналогично) из программ на Delphi.
а). Для чего это нужно ? Задачи могут быть самые разные, в общем случае это использование возможностей Word-а в своей программе, н-р: проверка текста на орфографию; печать текста, графики; экспорт отчетов в Word или изначальное создание их там и т.д. б). Подготовительные работы. На самом деле существует несколько способов сделать это, мы рассмотрим только один (пример кроме Delphi 5, в Delphi5 для этого есть компоненты на закладке Servers переименуете в программе типы на соответствующие компоненты, дальше так же). Для начала начнем новый проект File, New Application; File, Save All. Создадим отдельную папку для проекта и сохраним Unit1 как Main, а Project1 как WordWriter. Далее для работы с Word-ом нам потребуется библиотека типов Word-а, это делается так: Project, Import Type Library, Add, далее переходим в папку, где стоит Word ( у меня это - "c:\program files\microsoft office) , заходим в папку Office и выбираем файл - msword8.olb (цифра -? версии Word-а - у Вас может отличаться ) или excel8.olb (для Excel).Нажимаем Оk. Delphi создаст 2 файла - Word_tlb.pas и Office_tlb.pas, их надо включить в раздел uses модуля Main нашего проекта:
Code: Uses ... ,Office_Tlb, word_tlb;
в). Теперь займемся непосредственно программированием.
В разделе var опишем следующие переменные:
Code: // класс приложения ворда. WordApp:Word_tlb.Application_; // класс чего-то типа выделения, // т.е. говоришь - выделить ячейку с ... по, а результат скидываешь. // в эту перем и работаешь с этими ячейками как с 1 объектом. ARange,TempRange:Range; // массив документов. Docs:documents; // 1 документ. Doc:document; // массив параграфов. Pars:Paragraphs; // 1 параграф. Par:Paragraph; // параметры для передачи. Template,temp,OpenAsTemplate:olevariant; // массив таблиц. Tabls:Tables; // 1 таблица. Tabl:Table; // рабочая переменная. I:integer;
Далее проектируем форму:
1. Поместим вверх нашей формы кнопку - button1 типа tbutton, поменяем заголовок (св-во Caption) на 'Старт'.
2. Под кнопкой разместим панель - panel1 типа tpanel. Внутри панели поместим компонент - bevel1 типа tbevel, поменяем св-во Align на alClient (при этом рамка растянется на всю панель).
3. Сверху панели (далее все компоненты будут размещаться внутри этой панели) разместим метку - label1 типа tlabel, поменяем значение св-ва Caption на 'Передать в ячейку':
4. Ниже слева поместим метку - label1 типа tlabel, св-во Caption поменяем на 'X='
5. Правее метки помещаем компонент Edit1 типа tEdit, св-во Text меняем на '1'
6. По правой границе Edit1 помещаем компонент UpDown1 типа tUpDown, в списке св-ва 'Associate' выбираем Edit1, св-во 'Position' приравниваем '1'
7. Чуть отступаем вправо и повторяем шаги 4-6 , заменив Edit1 на Edit2, UpDown1 на UpDown2, Label1 на Label2 соответственно.
8. Ниже размещаем еще одну метку - label4 типа tlabel, меняем св-во 'Caption' на 'Новое значение ячейки:'
9. Ниже размещаем компонент Edit3 типа tEdit, св-во Text меняем на '0'
10. И, наконец, в самом низу панели размещаем кнопку BitBtn1 типа tBitBtn, меняем св-во 'Kind' на 'bkOk'.
Теперь напашем обработчики - именно в них и заключается вся функциональность программы: 1. Назначим обработчик OnClick компоненту Button1 :
Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. // если заголовок 'Выход', то закрываем программу. If button1.caption='Выход' then. Begin. Application.Terminate; Exit. End. // иначе (при первом начатии, когда у нас заголовок 'Старт'). //переименовываем заголовок в 'Выход' Else button1.caption:='Выход'; Panel1.Visible:=true; // создаем экземпляр ворда. WordApp:=CoApplication_.Create; // делаем его видимым. WordApp.Visible:=true; // шаблон. Template:='Normal'; // создать шаблон. OpenAsTemplate:=false; // что-то типа оператора with, можно было и напрямую обратиться. Docs:=WordApp.Documents; // добавляем документ. Doc:=Docs.Add(template,OpenAsTemplate); // выделить все. ARange:=Doc.Range(EmptyParam,EmptyParam); // массив параграфов. Pars:=doc.Paragraphs; // переменная - параметр. Template:=arange; // новый параграф. Par:=pars.Add(template); // цвет зеленный. Par.Range.Font.ColorIndex:=11; // вставляем текст. Par.Range.InsertBefore('Привет !!!'); // переменная - параметр. Template:=par.Range; // новый параграф, чтобы таблица не потерла текст. Par:=pars.Add(template); // цвет черный. Par.Range.Font.ColorIndex:=0; // вставляем текст. Par.Range.InsertBefore('Переключившись в программу, можно программно менять текст ячеек !'); // переменная - параметр. Template:=par.Range; // новый параграф, чтобы таблица не потерла текст. Par:=pars.Add(template); // выделяем параграф. Arange:=par.Range; // шрифт - жирный. ARange.Font.Bold:=1; // шрифт - рукописный. ARange.Font.Italic:=1; // получить массив таблиц. Tabls:=aRange.Tables; // добавляем новую таблицу размером 5 на 5. Tabl:=tabls.Add(arange,5,5); // в цикле. For i:=1 to 5 do. // задаем значение ячеек. Tabl.Cell(i,1).Range.Text:=inttostr(i); End;
2. Зададим обработчик формы:
Code: Procedure TForm1.FormDestroy(Sender: TObject); Var. // для параметров. SaveChanges:olevariant; Begin. // если Word не закрыт. If not VarIsEmpty(WordApp) then begin. { а можно сохранить автоматом: // имя файла в оле. Template:='Имя.doc'; // если не сохранен, то. If doc.Saved=false then. // сохраняем. Doc.SaveAs(template, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam); Короче, пишешь имя объекта, ставишь точку и нажимаешь. 'ctrl'+' ' и изучаешь существующие методы и св-ва. } //изменения не сохранять. SaveChanges:=false; // то закрыть сначала документ. Doc.Close(SaveChanges,EmptyParam,EmptyParam); // а потом и ворд. WordApp.Quit(SaveChanges,EmptyParam,EmptyParam). End; End;
3. Назначим обработчик OnClick компоненту Bitbtn1 :
Code: Procedure TForm1.BitBtn1Click(Sender: TObject); Begin. // в соотв ячейку ставим соотв значение, // а можно и наоборот - получать значение из ячейки в переменную. Tabl.Cell(UpDown2.Position,UpDown1.Position). Range.Text:=Edit3.Text; End;
в). В общем-то, это все ...
г). Дополнительная информация:
· Справка Word-а (по Visual Basic, по умолчанию она не ставится - запустите заново Setup и поставте в соотв. месте галочку).
· Книги: - Чарльз Калверт "Delphi 4. Энциклопедия пользователя" (издательство - DiaSoft) - Марко Кэнту "Delphi4 для профессионалов" (издательство - Питер).
· Если у Вас другая версия Word-а: Параметры ф-ций могут отличаться - обратитесь к справке (см выше) или если у Вас версия Delphi 3 и выше, то используем универсальный метод - пишешь имя объекта, ставишь точку (если нужно посмотреть список параметров у функции , то после открывающей скобки ) , нажимаешь 'ctrl'+'пробел' и изучаешь существующие методы и св-ва.
(c) 13 SoftWare.
Взято из http://delphi.chertenok.ru.
©Drkb::04436.
| Управляющие конструкции |
5. Управляющие конструкции.
ВВЕДЕНИЕ.
В четырех первых главах этой серии мы сконцентрировали свое внимание на синтаксическом анализе математических выражений и операций присваивания. В этой главе мы остановимся на новой и захватывающей теме: синтаксическом анализе и трансляции управляющих конструкций таких как, например, операторы IF.
Эта тема дорога для моего сердца, потому что является для меня поворотной точкой. Я играл с синтаксическим анализом выражений также как мы делали это в этой серии, но я все же чувствовал, что нахожусь еще очень далеко от возможности поддержки полного языка. В конце концов, реальные языки имеют ветвления, циклы, подпрограммы и все такое. Возможно вы разделяли некоторые из этих мыслей. Некоторое время назад, тем не менее, я должен был реализовать управляющие конструкции для структурного препроцессора ассемблера, который я писал. Вообразите мое удивление, когда я обнаружил, что это было гораздо проще, чем синтаксический анализ выражений, через который я уже прошел. Я помню подумал "Эй, это же просто!". После того, как мы закончим этот урок, я готов поспорить, что вы будете думать так же.
ПЛАН.
Далее мы снова начнем с пустого Cradle и, как мы делали уже дважды до этого, будем строить программу последовательно. Мы также сохраним концепцию одно-символьных токенов, которая так хорошо служила нам до настоящего времени. Это означает, что "код" будет выглядеть немного забавным с "i" вместо IF, "w" вместо WHILE и т.д. Но это поможет нам узнать основные понятия не беспокоясь о лексическом анализе. Не бойтесь... в конечном счете мы увидим что-то похожее на "настоящий" код.
Я также не хочу, чтобы мы увязли в работе с какими либо операторами кроме ветвлений, такими как операции присваивания, с которыми мы уже работали. Мы уже показали, что можем обрабатывать их, так что нет никакого смысла таскать этот лишний багаж в течение предстоящих занятий. Вместо этого я буду использовать анонимный оператор "other" для замены не управляющих операторов. Мы должны генерировать для них некоторый объектный код (мы возвращаемся к компиляции а не интерпретации), так что за неимением чего-либо другого я буду просто повторять входной символ.
Итак, тогда, начав с еще одной копии Cradle, давайте определим процедуру:
Code: { Recognize and Translate an "Other" }. Procedure Other; Begin. EmitLn(GetName); End;
Теперь включим ее вызов в основную программу таким образом:
Code: { Main Program }. Begin. Init; Other; End.
Запустите программу и посмотрите, что вы получили. Не очень захватывающе, не так ли? Но не зацикливайтесь на этом, это только начало, результат будет лучше.
Первое, что нам нужно - это возможность работать с более чем одним оператором, так как однострочные ветвления довольно ограничены. Мы делали это на последнем занятии по интерпретации, но сейчас давайте будем немного более формальными. Рассмотрите следующую БНФ:
<program> ::= <block> END.
<block> ::= [ <statement> ]*
Это означает, что программа определена как блок, завершаемый утверждением END. Блок, в свою очередь, состоит из нуля или более операторов. Пока у нас есть только один вид операторов.
Что является признаком окончания блока? Это просто любая конструкция, не являющаяся оператором "other". Сейчас это только утверждение END.
Вооружившись этими идеями, мы можем приступать к созданию нашего синтаксического анализатора. Код для program (мы должны назвать его DoProgram, иначе Pascal будет ругаться) следующий:
Code: { Parse and Translate a Program }. Procedure DoProgram; Begin. Block; If Look <> 'e' then Expected('End'); EmitLn('END'). End;
Обратите внимание, что я выдаю ассемблеру команду "END", что своего рода расставляет знаки препинания в выходном коде и заставляет чувствовать, что мы анализируем здесь законченную программу.
Код для Block:
Code: { Recognize and Translate a Statement Block }. Procedure Block; Begin. While not(Look in ['e']) do begin. Other; End; End;
(Из формы процедуры вы видите, что мы собираемся постепенно ее расширять!).
ОК, вставьте эти подпрограммы в вашу программу. Замените вызов Block в основной программе на вызов DoProgram. Теперь испытайте ее и посмотрите как она работает. Хорошо, все еще не так много, но мы становимся все ближе.
НЕМНОГО ОСНОВ.
Прежде чем мы начнем определять различные управляющие конструкции, мы должны положить немного более прочное основание. Во-первых, предупреждаю: я не буду использовать для этих конструкций тот же самый синтаксис с которым вы знакомы по Паскалю или Си. К примеру синтаксис Паскаль для IF такой:
IF <condition> THEN <statement>
(где <statement>, конечно, может быть составным.).
Синтаксис C аналогичен этому:
IF ( <condition> ) <statement>
Вместо этого я буду использовать нечто более похожее на Ada:
IF <condition> <block> ENDIF.
Другими словами, конструкция IF имеет специфический символ завершения. Это позволит избежать висячих else Паскаля и Си и также предотвращает необходимость использовать скобки {} или begin-end. Синтаксис, который я вам здесь показываю, фактически является синтаксисом языка KISS, который я буду детализировать в следующих главах. Другие конструкции также будут немного отличаться. Это не должно быть для вас большой проблемой. Как только вы увидите, как это делается, вы поймете, что в действительности не имеет большого значения, какой конкретный синтаксис используется. Как только синтаксис определен, включить его в код достаточно просто.
Теперь, все конструкции, с которыми мы будем иметь дело, включают передачу управления, что на уровне ассемблера означает условные и/или безусловные переходы. К примеру простой оператор IF:
IF <condition> A ENDIF B...
Должен быть переведен в:
Если условие не выполнено то переход на L.
A.
L: B.
...
Ясно, что нам понадобятся несколько процедур, которые помогут нам работать с этими переходами. Ниже я определил две из них. Процедура NewLabel генерирует уникальные метки. Это сделано с помощью простого способа называть каждую метку 'Lnn', где nn - это номер метки, начинающийся с нуля. Процедура PostLabel просто выводит метки в соответствующем месте.
Вот эти две подпрограммы:
Code: { Generate a Unique Label }. Function NewLabel: string; Var S: string; Begin. Str(LCount, S); NewLabel := 'L' + S; Inc(LCount); End; { Post a Label To Output }. Procedure PostLabel(L: string); Begin. WriteLn(L, ':'); End;
Заметьте, что мы добавили новую глобальную переменную LCount, так что вы должны изменить раздел описания переменных в начале программы, следующим образом:
Var Look : char; { Lookahead Character }.
Lcount: integer; { Label Counter }.
Также добавьте следующий дополнительный инициализирующий код в Init:
LCount := 0;
(Не забудьте сделать это, иначе ваши метки будут выглядеть действительно странными!).
В этом месте я также хотел бы показать вам новый вид нотации. Если вы сравните форму оператора IF, указанную выше, с ассемблерным кодом, который должен быть получен, то вы можете увидеть, что существуют некоторые определенные действия, связанные с каждым ключевым словом в операторе:
IF: Сначала получить условие и выдать код для него. Затем создать уникальную метку и выдать переход если условие ложно.
ENDIF: Выдать метку.
Эти действия могут быть показаны очень кратко, если мы запишем синтаксис таким образом:
IF.
<condition> { Condition; L = NewLabel; Emit(Branch False to L); } <block>
ENDIF { PostLabel(L) }.
Это пример синтаксически-управляемого перевода. Мы уже делали все это... мы просто никогда прежде не записывали это таким образом. Содержимое фигурных скобок представляет собой действия, которые будут выполняться. Хорошо в этом способе представления то, что он не только показывает что мы должны распознать, но также и действия, которые мы должны выполнить и в каком порядке. Как только мы получаем такой синтаксис, код возникает почти сам собой.
Почти единственное, что осталось сделать - конкретизировать то, что мы подразумеваем под "Переход если условие ложно".
Я полагаю, что должен быть код, выполняющийся для <condition>, который будет выполнять булеву алгебру и вычислять некоторый результат. Он также должен установить флажки условий, соответствующие этому результату. Теперь, обычным соглашением для булевых переменных является использование 0000 для представления значения "ложь" и какого-либо другого значения (кто-то использует FFFF, кто-то 0001) для представления "истины".
Процессор 68000 устанавливает флажки условий всякий раз, когда любые данные перемещаются или рассчитываются. Если данные равны 0000 (что соответствует условию ложь, запомните) будет установлен флажок ноль. Код для "перехода по нулю" - BEQ. Таким образом.
BEQ <=> Переход если ложь.
BNE <=> Переход если истина.
По природе вещей большинство ветвлений, которые мы увидим, будут BEQ... мы будем обходить вокруг кода, который должен выполняться когда условие истинно.
ОПЕРАТОР IF.
После этого небольшого пояснения метода мы наконец готовы начать программирование синтаксического анализатора для условного оператора. Фактически, мы уже почти сделали это! Как обычно я буду использовать наш одно-символьный подход, с символом "i" вместо "IF" и "e" вместо "ENDIF" (также как и END... это двойственная природа не вызывает никакого беспорядка). Я также пока полностью пропущу символ для условия ветвления, который мы все еще должны определить.
Код для DoIf:
Code: { Recognize and Translate an IF Construct }. Procedure Block; Forward; Procedure DoIf; Var L: string; Begin. Match('i'); L := NewLabel; Condition; EmitLn('BEQ ' + L); Block; Match('e'); PostLabel(L); End;
Добавьте эту подпрограмму в вашу программу и измените Block так, чтобы он ссылался на нее как показано ниже:
Code: { Recognize and Translate a Statement Block }. Procedure Block; Begin. While not(Look in ['e']) do begin. Case Look of. 'i': DoIf; 'o': Other; End; End; End;
Обратите внимание на обращение к процедуре Condition. В конечном итоге мы напишем подпрограмму, которая сможет анализировать и транслировать любое логическое условие которое мы ей дадим. Но это уже тема для отдельной главы (фактически следующей). А сейчас давайте просто заменим ее макетом, который выдает некоторый текст. Напишите следующую подпрограмму:
Code: { Parse and Translate a Boolean Condition }. { This version is a dummy }. Procedure Condition; Begin. EmitLn('<condition>'); End;
Вставьте эту процедуру в вашу программу как раз перед DoIf. Теперь запустите программу. Испробуйте строку типа:
Aibece.
Как вы можете видеть, синтаксический анализатор, кажется, распознает конструкцию и вставляет объектный код в правильных местах. Теперь попробуйте набор вложенных IF:
Aibicedefe.
Он начинает все более походить на настоящий, не так ли?
Теперь, когда у нас есть общая идея (и инструменты, такие как нотация и процедуры NewLabel и PostLabel) проще пареной репы расширить синтаксический анализатор для поддержки и других конструкций. Первое (а также и одно из самых сложных) это добавление условия ELSE в IF. В БНФ это выглядит так:
IF <condition> <block> [ ELSE <block>] ENDIF.
Сложность возникает просто потому, что здесь присутствует необязательное условие, которого нет в других конструкциях.
Соответствующий выходной код должен быть таким:
<condition>
BEQ L1 <block> BRA L2 L1: <block>
L2: ...
Это приводит нас к следующей синтаксически управляемой схеме перевода:
IF.
<condition> { L1 = NewLabel; L2 = NewLabel; Emit(BEQ L1) } <block> ELSE { Emit(BRA L2); PostLabel(L1) } <block>
ENDIF { PostLabel(L2) }.
Сравнение этого со случаем IF без ELSE дает нам понимание того, как обрабатывать обе эти ситуации. Код ниже выполняет это. (Обратите внимание, что использую "l" вместо "ELSE" так как "e" имеет другое назначение):
Code: { Recognize and Translate an IF Construct }. Procedure DoIf; Var L1, L2: string; Begin. Match('i'); Condition; L1 := NewLabel; L2 := L1; EmitLn('BEQ ' + L1); Block; If Look = 'l' then begin. Match('l'); L2 := NewLabel; EmitLn('BRA ' + L2); PostLabel(L1); Block; End; Match('e'); PostLabel(L2); End;
Вы получили его. Законченный анализатор/транслятор в 19 строк кода.
Сейчас протестируйте его. Испробуйте что-нибудь типа:
Aiblcede.
Работает? Теперь, только для того, чтобы убедиться, что мы ничего не испортили и случай с IF без ELSE тоже будет обрабатываться, введите.
Aibece.
Теперь испробуйте несколько вложенных IF. Испытайте что-нибудь на ваш выбор, включая несколько неправильных утверждений. Только запомните, что 'e' не является допустимым оператором "other".
ОПЕРАТОР WHILE.
Следующий вид оператора должен быть простым, так как мы уже имеем опыт. Синтаксис, который я выбрал для оператора WHILE следующий:
WHILE <condition> <block> ENDWHILE.
Знаю, знаю, мы действительно не нуждаемся в отдельных видах ограничителей для каждой конструкции... вы можете видеть, что фактически в нашей одно-символьной версии 'e' используется для всех из них. Но я также помню множество сессий отладки в Паскале, пытаясь отследить своенравный END который по мнению компилятора я хотел поместить где-нибудь еще. По своему опыту знаю, что специфичные и уникальные ключевые слова, хотя они и добавляются к словарю языка, дают небольшую защиту от ошибок, которая стоит дополнительной работы создателей компиляторов.
Теперь рассмотрите, во что должен транслироваться WHILE:
Code: L1: <condition> BEQ L2. <block> BRA L1. L2:
Управляющий протокол SNMP.
| Управляющий протокол SNMP. |
Управляющий протокол SNMP.
Internet - гигантская сеть. Напрашивается вопрос, как она сохраняет свою целостность и функциональность без единого управления? Если учесть разнородность ЭВМ, маршрутизаторов и программного обеспечения, используемых в сети, само существование Internet представится просто чудом. Так все же как решаются проблемы управления в Internet? Отчасти на этот вопрос уже дан ответ - сеть сохраняет работоспособность благодаря жесткой протокольной регламентации.
"Запас прочности" заложен в самих протоколах. Функции диагностики возложены, на протокол ICMP. Учитывая важность функции управления, для этих целей создано два протокола SNMP ( Simple Network Management Protocol - 1988г. ) и CMOT ( Common Management Information Services and Protocol over TCP/IP). Чаще всего управляющая прикладная программа воздействует на сеть по цепочке SNMP-UDP-IP-физическая_сеть. Наиболее важным объектом управления обычно является внешний порт сети или маршрутизатор. Каждому управляемому объекту присваивается уникальный идентификатор.
Протокол SNMP работает на базе протокола UDP и предназначен для использования сетевыми управляющими станциями. Он позволяет управляющим станциям собирать информацию о положении в сети Internet. Протокол определяет формат данных, их обработка и интерпретация остаются на усмотрение управляющих станций или менеджера сети. SNMP-сообщения не имеют фиксированного формата и фиксированных полей. При работе протокол SNMP использует управляющую базу данных (MIB — Management Information Base, RFC-1213,-1212).
Алгоритмы управления в Internet обычно описывают в нотации ASN.1 (Abstract Syntax Notation). Все объекты в Internet разделены на 10 групп и описаны в MIB: система, интерфейсы, обмены, трансляция адресов, IP, ICMP, TCP, UDP, EGP, SNMP. В группу "система" входит название и версия оборудования, операционной системы, сетевого программного обеспечения и пр. В группу "интерфейсы" входит число поддерживаемых интерфейсов, тип интерфейса, работающего под управлением IP (Ethernet, LAPB и т.д.), размер дейтограмм, скорость обмена, адрес интерфейса. IP-группа включает время жизни дейтограмм, информацию о фрагментации, маски субсетей и т.д. В TCP-группу входит алгоритм повторной пересылки, максимальное число повторных пересылок и пр. Команды SNMP приведены в табл. 1.15. В таблице PDU (Protocol Data Unit) - это тип протокольного сообщения. Взаимодействие источника SNMP-запросов с объектом управления показано на рис. 1.37.
Таблица 1.15.
Команда SNMP. Тип PDU. Назначение Get_request. 0. Получить значение указанной переменной или информацию о состоянии сетевого элемента Get_next_request. 1. Получить значение переменной, не зная точного ее имени (следующий логический идентификатор на дереве MIB). Set_request. 2. Присвоить переменной соответствующее значения. Используется для описания действие, которое должно быть выполнено Get response. 3. Отклик на get_request, get_next_request и set_request, Содержит также информацию о состоянии (коды ошибок и другие данные). Trap. 4. Отклик сетевого объекта на событие или на изменение состояния
Рис. 1.38. Формат SNMP-сообщений, вкладываемых в UDP-дейтограммы
Поле Версия содержит значение, равное номеру версии SNMP минус один. Поле Пароль (community - определяет группу доступа) содержит последовательность символов, которая является пропуском при взаимодействии менеджера и объекта управления. Обычно это поле содержит 6-байтовую строку public. Для запросов get, get-next и set значение поля Идентификатора запроса устанавливается менеджером и возвращается объектом управления в отклике get, что позволяет связывать в пары запросы и отклики. Поле Фирма (enterprise) = sysObjectlD объекта. Поле Статус ошибки характеризуется целым числом, присланным объектом управления (табл.1.16).
В последнее время широкое распространение получила идеология распределенного протокольного интерфейса DPI (Distributed Protocol Interface). Для транспортировки SNMP-запросов используется не только UDP-, но и TCP-протокол. Это дает возможность применять SNMP-протокол не только в локальных сетях. Форматы SNMP-DPI-запросов (версия 2.0) описаны в документе RFC-1592. Пример заголовка SNMP-запроса (изображенные поля образуют единый массив):Поле Флаг = 0х30 является признаком ASN.1-заголовка. Коды Ln представляют собой длины полей, начинающиеся с байта, который следует за кодом длины, вплоть до конца сообщения-запроса (n — номер поля длины), если не оговорено другое. Так, L1 - длина пакета-запроса от Т1 до конца пакета, a L3 — длина поля пароля. Субполя Tn — поля типа следующего за ними субполя запроса. Так, Т1=2 означает, что поле характеризуется целым числом, а Т2=4 указывает на то, что далее следует пароль (поле community, в приведенном примере Public). Цифры под рамками означают типовые значения субполей. Код ОхА является признаком GET-запроса, за ним следует поле кода PDU (=0...4, см. табл. 1.15). Блок субполей Идентификатора запроса служит для тех же целей, что и другие идентификаторы, — для определения пары запрос-отклик. Собственно идентификатор запроса может занимать один или два байта, что определяется значением Lиз. CO — статус ошибки (СО=0 - ошибки нет); ТМ — тип MIB-переменной (в приведенном примере Ох2В); ИО — индекс ошибки. Цифровой код MIB-переменной отображается последовательностью цифровых субполей, характеризующих переменную. Например, переменная 1.3.6.1.2.1.5 (в символьном выражении iso.org.dod.internet.mgmt.mib.icmp) соответствует последовательности кодов Ох2В 0х06 0х01 0х02 0х01 0х05 0х00.
Таблица 1.16.
Статус ошибки Имя ошибки Описание 0. 1. 2. NoError. TooBig. NoSuchName. Все в порядке Объект не может уложить отклик в одно сообщение В операции указана неизвестная переменная 3. 4. 5. BadValue. ReadOnly. GenErr. в команде set использована недопустимая величина или неправильный синтаксис менеджер попытался изменить константу Прочие ошибки
Если произошла ошибка, поле Индекс ошибки характеризует к какой из переменных это относится; индекс ошибки является указателем переменной и устанавливается объектом управления не равным нулю для ошибок badValue. Для команды trap (тип PDU-4 в табл. 1.15) формат сообщения меняется (рис. 1.38). Значения поля Тип trap приведены в табл. 1.17.
Таблица 1.17.
Тип trap. Имя trap. Описание 0. ColdStart. Установление начального состояния объекта 1. WannStart. Восстановление начального состояния объекта 2. LinkDown. Интерфейс выключился. Первая переменная в сообщении идентифицирует интерфейс 3. LinkUp. Интерфейс включился. Первая переменная в сообщении идентифицирует интерфейс 4. AuthenticationFailure. От менеджера получено SNMP-сообщение с Неверным паролем (community). 5. EgpNeighborLoss. EGP-партнер отключился. Первая переменная в сообщении определяет IP-адрес партнера 6. EntrpriseSpeclfic. Информация о trap содержится в поле Специальный код
Для поля Тип trap 0…4 поле Специальный код должно быть равно нулю. Поле Временная метка содержит число сотых долей секунды (число тиков) с момента инициации объекта управления. Так, прерывание coldStart выдается объектом через 200 мс после инициализации.
Протокол SNMP служит примером системы управления, в которой для достижения нужного результата не выдается команда, а осуществляется обмен информацией, решение принимается "на месте" в соответствии с полученными данными.
Управляющая база данных MIB.
Вся управляющая информация для контроля ЭВМ и маршрутизаторов Internet концентрируются в базе данных MIB (Management Information Base, RFC-1213). Именно эти данные используются протоколом SNMP. MIB определяет, например, что программное обеспечение IP должно хранить число всех октетов, которые приняты любым из сетевых интерфейсов, управляющие программы могут только читать эту информацию.
Согласно нормативам MIB управляющая информация делится на 8 категорий (табл. 1.18;см. также рис. 1.39).
Таблица 1.18.
MIB-категория Описание System. Interfaces. Addr. trans. Ip. Icmp. Tcp. Udp. Egp. Операционная система ЭВМ или маршрутизация Сетевой интерфейс Преобразование адреса (напр., с помощью ARP). Программная поддержка протоколов Internet. Программное обеспечение протокола ICMP. Программное обеспечение протокола TCP. Программное обеспечение протокола UDP. Программное обеспечение протокола EGP.
В табл. 1.19 - 1.24 представлены наиболее важные объекты базы данных MIB, перечисленные в табл. 1.18.
Помимо простых переменных объектами MIB могут быть таблицы. Для каждой таблицы имеется один или несколько индексов.
Таблица 1.19.
Системная переменная Описание SysDescr. SysObjectID. SysUpTime. SysContact. SysName. SysLocation. SysService. Текстовое описание объекта Идентификатор производителя в рамках дерева (1.3.6.1.4.1). Время с момента последней загрузки системы (TimeTicks). Имя системного менеджера и способы связи с ним Полное имя домена Физическое местоположение системы Величина, характеризует услуги, предоставляемые узлом (сумма номеров уровней модели OSI).
Таблица 1.20.
Переменная описания интерфейсов (ifTable). Тип данных Описание IfIndex. INTEGER. Список интерфейсов от 1 до ifNumber. IfDescr. DisplayString. Текстовое описание интерфейса IfType. INTEGER. Тип интерфейса, например, 6 - Ethernet; 9 - 802.5 маркерное кольцо; 23 - PPP; 28 - SLIP. IfNumber. INTEGER. Число сетевых интерфейсов IfMtu. INTEGER. MTU для конкретного интерфейса IfSpeed. Gauge. Скорость (бит/с). IfPhysAddress. PhysAddress. Физический адрес или строка нулевой длины для интерфейсов без физического адреса (например, последовательный). IfAdminStatus. [1…3]. Требуемое состояние интерфейса: 1 - включен; 2 - выключен; 3 - тестируется IfOperStatus. [1…3]. Текущее состояние интерфейса: 1, 2, 3. IfLastChange. TimeTicks. SysUpTime, когда интерфейс оказался в данном состоянии IfInOctets. Counter. Полное число полученных байтов IfInUcastPkts. Counter. Число пакетов, доставленных на верхний системный уровень (unicast). IfInDiscads. Counter. Число полученных, но отвергнутых пакетов IfInErrors. Counter. Число пакетов, полученных с ошибкой IfOutOctets. Counter. Число отправленных байтов IfOutUcastPkts. Counter. Число unicast-пакетов, полученных с верхнего системного уровня IfOutNUcastPkts. Counter. Число мультикастинг- и широковещательных пакетов, полученных с верхнего системного уровня IfOutDiscads. Counter. Количество отвергнутых пакетов из числа отправленных IfOutErrors. Counter. Число отправленных пакетов, содержащих ошибки IfOutQLen. Gauge. Число пакетов в очереди на отправку
Таблица 1.21.
Переменная Ip-группы Тип данных Описание IpDefaultTTL. INTEGER. Значение, которое используется IP в поле TTL. IpForwarding. [1…2]. 1 означает, что система переадресует дейтограммы (2 - нет). IpInReceives. Counter. Число полученных дейтограмм IpForwDatagrams. Counter. Число переадресованных дейтограмм IpOutNoRoutes. Counter. Число неудач при маршрутизации IpFragOKs. Counter. Число фрагментированных IP-дейтограмм IpRoutingTable. Таблица IP маршрутов IpInHdrErrors. Counter. Число IP-дейтограмм, отвергнутых из-за ошибки в заголовке IpInAddrErrors. Counter. Число IP-дейтограмм, отвергнутых из-за неверного адреса места назначения IpInUnknownProtos. Counter. Число локально адресованных дейтограмм с неверным кодом протокола IpInDiscards. Counter. Число дейтограмм, отвергнутых из-за нехватки места в буфере IpInDelivers. Counter. Число доставленных дейтограмм IpOutRequests. Counter. Полное число IP-дейтограмм, поступивших для пересылки без учета переадресованных IpOutDiscards. Counter. Число отправляемых дейтограмм, потерянных из-за нехватки места в буфере IpOutNoRoutes. Counter. Число потерянных IP-дейтограмм из-за отсутствия маршрута их доставки IpReasmTimeout. Counter. Максимальное время (в секундах), которое IP-фрагмент может ждать сборки IpReasmOKs. Counter. Число IP-дейтограмм, успешно прошедших сборку IpReasmFails. Counter. Число случаев, когда алгоритм сборки не сработал IpFragOKs. Counter. Число дейтограмм, успешно фрагментированных IpFragFails. Counter. Число дейтограмм, которые нуждались в фрагментации, но не могли быть фрагментированы из-за того, что don't fragment_флаг=1. IpFragCreates. Counter. Число фрагментов, созданных в процессе фрагментации IpRoutingDiscards. Counter. Число маршрутных записей, помеченных для ликвидации, хотя они и корректны Таблица IP-адресов (ipAddrTable), индекс =<ipAdEntAddr> IpAdEntAddr IpAddress IP-адрес для данного ряда IpAdEntIfIndex INTEGER Число интерфейсов IpAdEntNetMask IpAddress Маска субсети для данного IP-адреса IpAdEntBcastAddr [0…1] Значение младшего бита широковещательного адреса (обычно 1). IpAdEntReasmMaxSize [0…65535] Размер наибольшей IP-дейтограммы, полученной интерфейсом, которая может быть собрана
Таблица 1.22.
Переменная Tcp-группы Тип данных Описание TcpRtoMin. INTEGER. Минимальное допустимое время повторной передачи TCP-пакетов TcpRtoMax. INTEGER. Максимальное значение тайм-аута (в миллисекундах). TcpMaxConn. INTEGER. Максимальное допустимое число TCP-соединений TcpInSegs. Counter. Полное число полученных TCP-сегментов TcpRtoAlgorithm. INTEGER. Алгоритм, используемый для вычисления тайм-аута: 1 - ни один из следующих; 2 - постоянное RTO; 3 - стандарт MIL-STD-1778; 4 - алгоритм Ван Джакобсона TcpActiveOpens. Counter. Число переходов из состояния CLOSED в SYN_SENT. TcpPassiveOpens. Counter. Число переходов из состояния LISTEN в SYN_RCVD. TcpAttemptFails. Counter. Число переходов из состояния SYN_SENT или SYN_RCVD в CLOSED. TcpEstabResets. Counter. Число переходов из состояния ESTABLISHED или CLOSE_WAIT в CLOSED. TcpCurrEstab. Gauge. Число соединений, находящихся в состоянии ESTABLISHED или CLOSE_WAIT. TcpInSegs. Counter. Полное число полученных сегментов TcpOutSegs. Counter. Полное число посланных сегментов, исключая повторно пересылаемые TcpRetransSegs. Counter. Полное число повторно пересланных сегментов TcpInErrs. Counter. Полное число сегментов, полученных с ошибкой TcpOutRsts. Counter. Полное число посланных сегментов с флагом RST=1. TcpConnTable TCP-таблица связей TcpConnState [1…12] Состояние соединения: 1 - CLOSED; 2 -LISTEN; 3 - SYN_SENT; 4 - SYN_RCVD; 5 - ESTABLISHED; 6 - FIN_WAIT_1; 7 - FIN_WAIT_2; 8 - CLOSE_WAIT; 9 - LAST_ACK; 10 - CLOSING; 11 - TIME_WAIT; 12 - delete TCB. Только последняя переменная может устанавливаться менеджером, прерывая связь TcpConnLocalAddress IpAddress Местный IP-адрес 0.0.0.0 означает, что приемник готов установить связь через любой из интерфейсов TcpConnLocalPort [0…65535] Местный номер порта TcpConnLocalAddress ipAddress Удаленный IP-адрес TcpConnRemPort [0…65535] Удаленный номер порта
Таблица 1.23.
Переменная Icmp-группы Тип данных Описание IcmpInEchos. Counter. Число полученных ICMP-запросов отклика IcmpInMsgs. Counter. Полное число полученных ICMP-сообщений IcmpInErrors. Counter. Число ICMP-сообщений, полученных с ошибками IcmpInDestUnreach. Counter. Число ICMP-сообщений о недостижимости адресата IcmpInTimeExcds. Counter. Число ICMP-сообщений об истечении времени IcmpInParmProbs. Counter. Число полученных ICMP-сообщений о проблемах с параметрами IcmpInSrcQuench. Counter. Число ICMP-сообщений с требованием сократить или прервать посылку пакетов из-за перегрузки IcmpInRedirects. Counter. Число ICMP-сообщений о переадресации IcmpInEchoReps. Counter. Число полученных ICMP-эхо-откликов IcmpInTimestamps. Counter. Число ICMP-запросов временных меток IcmpInAddrMasks. Counter. Число ICMP-запросов адресных масок IcmpOutMsgs. Counter. Число отправленных ICMP-сообщений IcmpOutErrors. Counter. Число неотправленных ICMP-сообщений из-за проблем (например, нехватка буферов). IcmpOutTimesExcds. Counter. Число посланных ICMP-сообщений об истечении времени IcmpOutParmProbs. Counter. Число посланных ICMP-сообщений о проблемах с параметрами IcmpOutQuench. Counter. Число посланных ICMP-сообщений об уменьшении потока пакетов IcmpOutRedirects. Counter. Число посланных ICMP-сообщений о переадресации IcmpOutEchos. Counter. Число посланных ICMP-эхо-запросов IcmpOutEchoReps. Counter. Число посланных ICMP-эхо-откликов IcmpOutTimestamps. Counter. Число посланных ICMP-эхо-запросов временных меток IcmpOutAddrMasks. Counter. Число посланных ICMP-эхо-запросов адресных масок
Таблица 1.24.
Переменные at-группы (atTable). Тип данных Описание AtIfIndex. INTEGER. Число интерфейсов AtPhysAddress. PhysAddress. Физический адрес. Если эта переменная равна строке нулевой длины, физический адрес отсутствует AtNetAddress. NetworkAddress. IP-адрес
Каждый протокол (например, IP) имеет свою таблицу преобразования адресов. Для IP это ipNetToMediaTable. Способ пропечатать таблицу преобразования с помощью программы snmpi описан ниже.
В новейшей модификации управляющей базы данных (MIB II) содержатся объекты, принадлежащие к SNMP-группе. Эта группа предоставляет информацию о SNMP-объектах, информационных потоках, статистике ошибок (табл. 1.25).
Таблица 1.25.
Название объекта Описание SnmpInPkts. Число пакетов, полученных от слоя, расположенного ниже SNMP. SnmpOutPkts. Число пакетов доставленных от SNMP к нижележащему слою SnmpInBadVersions. Индицирует число PDU, полученных с ошибкой в поле Версия (см. рис. 1.38). SnmpInBadCommunityNames. Индицирует число сообщений PDU, полученных с нечитаемым или нелегальным именем community. SnmpInASNParsErrs. Указывает число PDU, которые не могут быть преобразованы в объекты ASN.1, и наоборот SnmpInBadTypes. Указывает число полученных PDU с недешифруемым типом SnmpInTooBigs. Указывает число полученных PDU со слишком большим значением поля Статус ошибки (см. рис. 1.38). SnmpInNoSuchNames. Указывает число PDU, полученных с индикацией ошибки в поле NoSuchName (см. табл. 1.16). SnmpInBadValues. Указывает число PDU, полученных с индикацией ошибки в поле BadValue (см. табл. 1.16). SnmpInReadOnlys. Указывает число PDU, полученных с индикацией ошибки в поле ReadOnly (см. табл. 1.16). SnmpInGenErrs. Указывает число PDU, полученных в GenErr-поле (см. табл. 1.16). SnmpInTotalReqVar. Указывает число объектов MIB, которые были восстановлены SnmpInTotalSetVars. Указывает число объектов MIB, которые были изменены SnmpInGetRequests. SnmpInGetNexts. SnmpInSetRequests. SnmpInGetResposes. SnmpInTraps. Указывает число соответствующих PDU, которые были получены SnmpOutTooBig. Указывает число посланных PDU с полем TooBig. SnmpOutNoSuchNames. Указывает число посланных PDU с полем NoSuchName. SnmpOutBadValues. Указывает число посланных PDU с полем BadValue. SnmpOutReadOnlys. Указывает число посланных PDU с полем ReadOnly. SnmpOutGenErrs. Указывает число посланных PDU с полем GenErr. SnmpEnableAuthTraps. Говорит о том, разрешены или нет ловушки (traps). SnmpOutGetRequests. SnmpOutGetNexts. SnmpOutSetRequests. SnmpOutGetResposes. SnmpOutTraps. Указывает число соответствующих посланных PDU.
Стандарт на структуру управляющей информации (SMI) требует, чтобы все MIB-переменные были описаны и имели имена в соответствии с ASN.1 (Abstract Syntax Notation 1, формализованный синтаксис). ASN.1 является формальным языком, который обладает двумя основными чертами: нотация в документах легко читаема и понимаема; в компактном кодовом представлении информация может использоваться коммуникационными протоколами. В SMI присутствует неполный набор типов объектов, предусмотренный в ASN.1, разрешены только следующие типы примитивов: INTEGER, OCTET STRING, OBJECT IDENTIFIER и NULL. Практически в протоколе SNMP фигурируют следующие виды данных:
INTEGER. Некоторые переменные объявляются целыми (INTEGER) с указанием начального значения или с заданным допустимымы диапазоном значений (в качестве примера можно привести номера UDP- или TCP-портов).
OCTET STRING (последовательность байтов). В соответствии с требованиями BER (Basic Encoding Rules, ASN.1) последовательность октетов должна начинаться с числа байтов в этой последовательности (от 0 до N).
OBJECT IDENTIFIER (идентификатор объекта). Имя объекта, представляющее собой последовательность целых чисел, разделенных точками. Например, 1.3.6.1.2.1.5.
NULL. Указывает, что соответствующая переменная не имеет значения.
DisplayString. Строка из 0 или более байтов (но не больше 255), которые являются ASCII-символами. Представляет собой частный случай OCTET STRING.
PhysAddress. Последовательность октетов, характеризующая физический адрес объекта (6 байт для Ethernet). Частный случай OBJECT IDENTIFIER.
Сетевой адрес. Допускается выбор семейства сетевых протоколов. В рамках ASN.1 этот тип описан как CHOICE, он позволяет выбрать протокол из семейства протоколов. В настоящее время идентифицировано только семейство протоколов Internet.
IP-адрес. Этот адрес используется для определения 32-разрядного Интернет - адреса. В нотации ASN.1 - это OCTET STRING.
Time Ticks (такты часов). Положительное целое число, которое используется для записи, например, времени последнего изменения параметров управляемого объекта, или времени последней актуализации базы данных (время измеряется в сотых долях секунды).
Gauge (масштаб). Положительное целое число в диапазоне 0..232-1, которое может увеличиваться или уменьшаться. Если это число достигнет 232-1, то будет оставаться неизменным до тех пор, пока не будет обнулено командой сброс. Примером может служить переменная tcpCurrEsta, которая характеризует число TCP-соединений, находящихся в состоянии ESTABLISHED или CLOSE_WAIT.
Counter (счетчик). Положительное число в диапазоне 0..232-1, которое может только увеличиваться, допуская переполнение.
SEQUENCE. Этот объект аналогичен структуре в языке Си. Например, MIB определяет SEQUENCE с именем UdpEntry, содержащую информацию об активных UDP-узлах. В этой структуре содержится две записи:
1. UdpLocalAddress типа IpAddress; местные IP-адреса;
1. UdpLocalPort типа INTEGER; номера местных портов.
SEQUENCE OF. Описание вектора, все элементы которого имеют один и тот же тип. Элементы могут представлять собой простые объекты, например, типа целое. В этом случае мы имеем одномерный список. Но элементами вектора могут быть объекты типа SEQUENCE, тогда этот вектор описывает двумерный массив.
В MIB Internet каждый объект должен иметь имя (OBJECT IDENTIFIER), синтакс и метод кодировки.
Стандарт ASN.1 определяет форму представления информации и имен. Имена MIB-переменных соответствуют в свою очередь стандартам ISO и CCITT. Структура имен носит иерархический характер, отображенный на рис. 1.39.
В табл. 1.26 охарактеризованы четыре простые переменные, идентификаторы которых помещены в нижней части рис. 1.39. Все эти переменные допускают только чтение.
В табл. 1.27 приведено описание таблицы udpTable (index=<udpLocalAddress>,<udpLocalPort>), состоящей из двух простых переменных, предназначенных только для чтения.
Согласно иерархии рис. 1.39 переменные, соответствующие icmp, должны иметь префикс (идентификатор) 1.3.6.1.2.1.5 или в символьном выражении iso.org.dod.internet.mgmt.mib.icmp. Если вы хотите узнать значение какой-то переменной, следует послать запрос, содержащий соответствующие префикс и суффикс (последний определяет имя конкретной переменной). Для простой переменной суффикс имеет вид .0.
Рис. 1.39. Структура идентификаторов переменных в MIB.
Таблица 1.26.
Имя Переменной Тип данных Описание UdpInDatagrams. Counter. Число UDP-дейтограмм, присланных процессам пользователя UdpNoPorts. Counter. Число полученных UDP-дейтограмм, для которых отсутствует прикладной процесс в порте назначения UdpInErrors. Counter. Число не доставленных UDP-дейтограмм (например, ошибка контрольной суммы). UdpDatagrams. Counter. Число посланных UDP-дейтограмм
Таблица 1.27.
Имя переменной Тип данных Описание UdpLocalAddress. UdpLocalPort. IpAddress. (0...65535). Местный IP-адрес для данного приемника Местный номер порта приемника
Лучшим способом закрепить в памяти все вышесказанное является использование программы snmpi (SNMP initiator или SNMPWALK, NETGUARD, SNMPMAN для PC). Если в вашем распоряжении имеется ЭВМ, работающая под управлением UNIX, например SUN, вы можете попутно узнать много полезного о вашей локальной сети. Синтаксис обращения к snmpi:
Snmpi [-a agent] [-с community] [-f file] [-p portno] [-d] [-v] [-w].
Программа snmpi крайне проста. Для того чтобы проверить, работает ли онa, выдайте команду
% snmpi dump.
Следует отметить, что в ответ на эту операций будет произведена весьма объемная выдача.
Опция -a предлагает возможность ввести адрес SNMP-обьекта: имя ЭВМ, IP-адрес или транспортный адрес. По умолчанию это местная ЭВМ. Аналогично опция -р позволяет задать номер UDP-порта. По умолчанию это порт 61.
Опция -с позволяет задать групповой пароль (community) для SNMP-запроса. По умолчанию это public, т.е. свободный доступ.
Опция -f позволяет выбрать файл, содержащий откомпилированные описания MIB-модулей. По умолчанию это objects.defs.
Опция -w включает режим наблюдения, осуществляя выдачу на терминал всех служебных сообщений. Уход из программы - по команде quit (q).
Если вы работаете на IBM PC, и ваша машина подключена к локальной сети, получите допуск к одной из UNIX-машин в сети (если вы его не имели) и приступайте. Можно начать с обращения типа
Snmpi -a 193.124.224.33.
(адрес или символьное имя надо взять из вашей локальной сети).
Машина откликнется, отобразив на экране snmpi>. Это означает, что программа имеется и вы можете вводить любые команды.
Начать можно со знакомства с системными переменными системы (как и ранее курсивом выделены команды, введенные с клавиатуры).
Snmpi> get sysDescr.0.
Snmpi> sysDescr.0="GS Software (GS3-K), Version 9.1(4) [fc1], SOFTWARE Copyright ї 1986-1993 by Cisco Systems, Inc. Compiled Thu 25-Mar-93 09:49 by daveu".
Snmpi> get sysObjectID.0.
Snmpi> sys0bjectlD.0=1.3.6.1.4.1.9.1.1.
Snmpi> get sysUpTime.0.
Snmpi> sysUpTime.0=14 days, 7 hours, 0 minutes, 15.27 seconds (123481527 timeticks).
Snmpi> get sysServices.0.
Snmpi> sysServices.0=0x6<datalink/subnetwork, internet>
Код 0x06 (sysServices.0) представляет собой сумму кодов уровней модели SO, поддерживаемых системой. Для справок: 0х01 - физический уровень; 0х02 связной уровень; 0х04 - Интернет; 0х08 - связь точка-точка; 0х40 - прикладной уровень.
Если вы хотите получить информацию о состоянии интерфейсов на одной из ЭВМ, подключенных к вашей локальной сети (команды вызова snmpi далее не повторяются; в ниже приведенных примерах в круглых скобках помещены комментарии автора), выдайте команды:
Snmpi> nextifTable.
(команда next в данном случае соответствует запросу get-next, здесь понятие "следующий" подразумевает порядок переменных в MlВ).
Snmpi> iflndex.1=1.
Snmpi> get ifDescr.1.
Snmpi> ifDescr.1="Ethernet0".
Snmpi> get ifType.1.
Snmpi> ifType.1=ethernet-csmacd (6).
Snmpi > get ifMtu.1.
Snmpi> IfMtu.1=1500.
Snmpi> get ifSpeed.1.
Snmpi> ifSpeed.1=10000000 (10М бит/с, Ethernet).
Snmpi> get ifPhysAddress.1.
Snmpi> ifPhysAddress.1=0х00:00:0c:02:За:49 (физический адрес интерфейса).
Snmpi> next ifDescr.1 ifType.1 ifMtu.1 ifSpeed.1 ifPhysAddress.1.
Snmpi> ifDescr.2="Serial0".
IfType.2=propPointToPointSerial(22).
IfMtu.2=1500.
IfSpeed.2=2048000 (2 M бит/с, радиорелейный последовательный канал, спутниковый канал был бы охарактеризован точно также).
В приведенном примере размеры пересылаемых блоков для Ethernet и радиорелейного последовательного канала идентичны и равны 1500 байт. Помните, что SLIP-канал записан как PointToPointSerial, а не как SLIP. Скорость обмена по SLIP-каналу не сообщается.
Теперь просмотрим некоторые UDP-переменные. Например:
Snmpi> next udp.
Snmpi> udpInDatagrams.0=98931.
Snmpi> next udpInDatagrams.0 (обратите внимание на суффикс простой переменной).
Snmpi> udpNoPorts. 0=60009.
Snmpi> next udpLocalAddress.0.
Snmpi> udpLocalAddress.193.124.137.14.7=193.124.137.14 (Идентификатор этого объекта 1.3.6.1.2.1.7.5.1.1.193.124.137.14.7).
Snmpi> next udpLocalPort.
Snmpi> udpLocalPort.193.124.137.14.7=7.
Если у вас возникла необходимость просмотреть таблицу, например, udpTable, это также можно сделать, используя snmpi:
Snmpi> next udpTable.
Snmpi> udpLocalAddress.193.124.137.14.7=193.124.137.14.
Snmpi> next udpLocalAddress.193.124.137.14.7.
Snmpi> udpLocalAddress.193.124.224.33.67=193.124.224.33.
Snmpi> next udpLocalAddress.193.124.224.33.67.
Snmpi> udpLocalAddress.193.124.224.33.161=193.124.224.33.
Snmpi> next udpLocalPort.193.124.224.33.67.
Snmpi> udpLocalPort.193.124.224.33.161=161.
Ниже показана методика выяснения алгоритма и параметров задания значения тайм-аута:
Snmpi> get tcpRtoAlgorithm.0 tcpRtoMin.0 tcpRtoMax.0 tcpMaxConn.0.
Snmpi> tcpRtoAlgorithm.0=vanj(4) (vanj - алгоритм Ван Джакобсона для расчета времени тайм-аута).
TcpRtoMin.0=300 (минимальное значение тайм-аута = 300 мс).
TcpRtoMax.0=60000 (максимальное - 60 с).
TcpMaxConn.0=-1 (никаких ограничений на число соединений).
Чтобы получить информацию о состоянии таблицы адресных преобразований, выдайте команду snmpi -а 193.124.224.33 dump at (процедуры с использование субкоманды dump требуют некоторого времени для своего исполнения). В результате получим:
AtIfIndex.1.1.193.124.224.33=1.
AtIfIndex.1.1.193.124.224.35=1.
AtIfIndex.3.1.192.148.166.203=3.
AtIfIndex.3.1.192.148.166.205=3.
AtIfIndex.5.1.145.249.30.33=5.
AtIfIndex.5.1.192.148.166.98=5.
AtPhysAddress.1.1.193.124.224.33=0x00:00:0c:02:3a:49.
AtPhysAddress.1.1.193.124.224.35=0x00:00:20:12:1b:b1.
AtPhysAddress.1.1.193.124.224.40=0x00:00:cd:f9:0d:e7.
AtPhysAddress.1.1.193.124.224.50=0x00:00:0c:02:fb:c5.
AtNetAddress.1.1.193.124.224.33=193.124.224.33.
AtNetAddress.1.1.193.124.224.35=193.124.224.35.
AtNetAddress.1.1.193.124.224.40=193.124.224.40.
AtNetAddress.1.1.193.124.224.50=193.124.224.50.
AtNetAddress.1.1.193.124.224.60=193.124.224.60.
(текст выдачи сокращен).
Обычно элементы таблицы расположены в порядке колонка-ряд. Если вы дошли до края колонки или всей таблицы, ЭВМ выдаст (в зависимости от реализации программы) имя и значение следующего элемента или сообщение об ошибке.
Чтобы получить полный текст адресной таблицы в рамках snmpi достаточно выдать команду
Snmpi> dump ipAddrTable.
Snmpi> ipAdEntAddr.192.148.166.222=192.148.166.222.
IpAdEntAddr.192.168.1.1=192.168.1.1.
IpAdEntAddr.192.168.1.2=192.168.1.2.
IpAdEntAddr.193.124.224.33=193.124.224.33.
IpAdEntAddr.193.124.224.190=193.124.224.190.
IpAdEntIfIndex.192.148.166.222=3.
IpAdEntIfIndex.192.148.1.1=4.
IpAdEntIfIndex.192.148.1.2=6.
IpAdEntIfIndex.192.148.224.33=1.
IpAdEntIfIndex.192.148.224.190=5.
(маски субсетей).
IpAdEntNetMask.192.148.166.222=255.255.255.224.
IpAdEntNetMask.192.148.1.1=255.255.255.0.
IpAdEntNetMask.192.148.1.2=255.255.255.0.
IpAdEntNetMask.192.148.224.33=255.255.255.224.
IpAdEntNetMask.192.148.224.190=255.255.255.224.
IpAdEntBcastAddr.192.148.166.222=1 (все эти субсети используют для широковещательной адресации одни и те же биты).
IpAdEntBcastAddr.192.148.1.1=1.
IpAdEntBcastAddr.192.148.1.2=1.
IpAdEntBcastAddr.192.148.224.33=1.
IpAdEntBcastAddr.192.148.224.190=1.
IpAdEntReasmMaxSize.192.148.166.222=18024 (с точки зрения фрагментации и последующей сборки дейтограмм данные субсети эквивалентны).
IpAdEntReasmMaxSize.192.148.1.1=18024.
IpAdEntReasmMaxSize.192.148.1.2=18024.
IpAdEntReasmMaxSize.192.148.224.33=18024.
IpAdEntReasmMaxSize.192.148.224.190=18024.
Эта распечатка совместно с приведенной для IfTable позволяет получить достаточно полную картину о данной конкретной локальной сети. Чтобы познакомиться с ARP таблицей, можно воспользоваться командой
Sun> arp -a.
Itepgw.itep.ru (193.124.224.33) at 0:0:c:2:3a:49.
Nb.itep.ru (193.124.224.60) at 0:80:ad:2:24:b7.
И дополнить полученные данные с помощью snmpi:
Snmpi> dump ipNetToMediaTable.
Snmpi> ipNetToMediaIfIndex.1.193.124.224.33=1.
IpNetToMediaIfIndex.1.193.124.224.35=1.
IpNetToMediaIfIndex.3.192.148.166.193=3.
IpNetToMediaIfIndex.3.192.148.166.196=3.
IpNetToMediaIfIndex.3.193.124.226.110=3.
IpNetToMediaIfIndex.5.195.249.30.33=5.
IpNetToMediaIfIndex.5.192.148.166.100=5.
IpNetToMediaPhysAddress.1.193.124.224.33=0x00:00:0c:02:3a:49.
IpNetToMediaPhysAddress.3.192.148.166.196=0xaa:00:04:00:0c:04.
IpNetToMediaPhysAddress.3.192.148.166.198=0xaa:00:04:00:0e:04.
IpNetToMediaPhysAddress.3.192.148.166.203=0x00:00:01:00:54:62.
…………………………
IpNetToMediaPhysAddress.5.195.249.30.33=0x00:00:0c:02:69:7d.
IpNetToMediaPhysAddress.5.192.148.166.100=0x00: 20:af: 15:c1: 61.
IpNetToMediaPhysAddress.5.192.148.166.101=0x00:00:09:42:0d:e8.
IpNetToMediaNetAddress.1.193.124.224.33=193.124.224.33.
IpNetToMediaNetAddress.1.193.124.224.35=193.124.224.35.
IpNetToMediaNetAddress.3.192.148.166.193=192.148.166.193.
IpNetToMediaNetAddress.3.193.124.226.110=193.124.226.110.
IpNetToMediaNetAddress.5.195.249.30.33=195.249.30.33.
IpNetToMediaType.1.193.124.224.33=other(1).
IpNetToMediaType.1.193.124.224.35=dynamic(3).
IpNetToMediaType.1.193.124.224.37=dynamic(3).
IpNetToMediaType.3.192.148.166.195=dynamic(3).
IpNetToMediaType.3.192.148.166.222= other(1).
IpNetToMediaType.5.193.124.224.190= other(1).
IpNetToMediaType.5.193.124.225.33= other(1).
IpNetToMediaType.5.193.124.225.35=dynamic(3).
Синтаксис каждого объекта описывается в рамках ASN.1 и показывает побитовое представление объекта. Кодирование объекта характеризует то, как тип объекта отображается через его синтаксис и передается по телекоммуникационным каналам. Кодирование производится в соответствии с базовыми правилами кодирование ASN.1. Все описания объектов базируются на типовых шаблонах и кодах ASN.1 (см. RFC-1213). Формат шаблона:
OBJECT (объект):
Имя типа объекта с соответствующим ему идентификатором объекта
(OBJECT IDENTIFIER).
Syntax (синтаксис):
ASN.1 описание синтаксиса типа объекта
Definition (Определение).
Текстовое описание типа объекта
Access (доступ).
Опции доступа
Status (состояние).
Статус типа объекта.
Маршруты также являются объектами MIB. Согласно требованиям к MIB, каждому маршруту в этой базе соответствует запись, схема которой приведена на рис. 1.40.
Поле Место назначения представляет собой IP-адрес конечной точки маршрута. Поле Индекс интерфейса определяет локальный интерфейс (физический порт), через который можно осуществить следующий шаг по маршруту. Следующие пять полей (Метрика 1…5) характеризует оценку маршрута. В простейшем случае, например для протокола RIP, достаточно было бы одного поля. Но для протокола OSPF необходимо пять полей (разные TOS). Поле Следующий шаг представляет собой IP-адрес следующего маршрутизатора. Поле Тип маршрута имеет значение 4 для опосредованного достижения цели маршрута; 2 для нереализуемого маршрута и 1 для случаев, отличных от вышеперечисленных.
Место назначения (ipRouteDept). Индекс интерфейса (ipRouteIfIndex). Метрика 1 (ipRouteMetric1). ……. Метрика 5 (ipRouteMetric5). Следующий шаг (ipRouteNextHop). Тип маршрута (ipRouteType). Протокол маршрутизации (ipRouteProto). Возраст маршрута (ipRouteAge). Маска маршрута (ipRouteMask). Маршрутная информация (ipRouteInfo).
Рис. 1.40. Маршрутная таблица
Поле Протокол маршрутизации содержит код протокола. Для RIP этот код равен 8, для OSPF -13, для BGP -14, для ICMP -4, для прочих протоколов -1. Поле Возраст маршрута описывает время (в секундах), прошедшее с момента последней коррекции маршрута. Следующее поле Маска маршрута используется для выполнения логической побитовой операции И над адресом в IP-дейтограмме перед сравнением результата с кодом, хранящимся в первом поле записи ("место назначения"). Последнее поле Маршрутная информация содержит код, зависящий от протокола маршрутизации и обеспечивающий ссылки на соответствующую информацию в базе MIB.
©Drkb::03394.
| Тянем пароли из кэша |
Так, сегодня мы рассмотрим как можно взять кэшированные пароли из 9x винды, а также из винды, где в установленном виде есть 5-я иешка (хотя может и 4-ой хватит:).
| Универсальная функция возврата значения элемента даты |
Автор: Галимарзанов Фанис
| Фокус ячейки TStringGrid. |
Автор: Simon.
Code: Procedure SetGridFocus(SGrid: TStringGrid; r, c: integer); Var. SRect: TGridRect; Begin. With SGrid do. Begin. SetFocus; {Передаем фокус сетке}. Row := r; {Устанавливаем Row/Col}. Col := c; SRect.Top := r; {Определяем выбранную область}. SRect.Left := c; SRect.Bottom := r; SRect.Right := c; Selection := SRect; {Устанавливаем выбор}. End; End; //Для вызова процедуры: SetGridFocus(StringGrid1, 10, 2);
| Упорядочивание случайных чисел |
Code: { **** UBPFD *********** by kladovka.net.ru **** >> Упорядочивание случайных чисел. Как то спросил я у товарищей мастеров: «Как можно научить. Random не повторятся в определенном пределе?», ответ. Был примерно таков (вернее два): «…сравнивать надо…», «…кто сказал, что числа не должны повторятся…». Так, что. Получается либо они не знают, как это сделать, либо на. Самом деле это невозможно без сравнения. Тогда пришлось написать такую не большую "процедурку". (см. ниже), заполнения массива случайными не повторяющимися числами. Только здесь существует одно условие передаваемый в процедуру. Массив должен быть таким, какой определен в процедуре или можно. Написать две (или более) процедуры overload. Если кто не знает, как сделать тоже вот пользуйтесь. Зависимости: System, Windows. Автор: 16xmax, 16xmax@rambler.ru, Самара. Copyright: Кошеленко Дмитрий т.е. Я. Дата: 18 апреля 2004 г. ********************************************** } Type. SortDir = (SU, SD, US); // типы сортировок: SU – возрастающая, SD – убывающая, US без сортировки. Procedure rnd(arr: array of integer; sort: SortDir); Label 1; // метка возврата для регенерации числа. Var. I, j, l, m: integer; // необходимые переменные. Begin. For i:=Low(arr) to High(arr) do // цикл от первого значения до последнего массива. Begin. 1: // метка возврата. Randomize; // холостой прогон генератора. L:=random(High(arr)+1); // генерация числа от верхнего значения массива +1. J:=Low(arr); // присвоение счетчику сравнения минимального значения массива. If i=Low(arr) then //если счетчик цикла равен первому значению тогда. Arr[i]:=l // просто вносим его в массив. Else // иначе. While j<i do // пока счетчик сравнения меньше счетчика цикла выполняем. If l=arr[j] then // если сгенерированное число уже есть в массиве тогда. Goto 1 // возвращаемся к метке возврата. Else //иначе. Begin. Arr[i]:=l; // вносим число в массив. Inc(j); // увеличиваем счетчик сравнения на единицу. End; End; If sort=SU then // если переменная сортировки равна: по возрастающей тогда. For i:=Low(arr) to High(arr)-1 do // с первого значения до предпоследнего прогоняем массив. For j:=i+1 to High(arr) do // со второго значения до последнего прогоняем массив для сравнения и сортировки. Begin. L:=arr[i]; //присваиваем значение первое. M:=arr[j]; // присваиваем значение второе. If l<m then begin arr[i]:=m; arr[j]:=l; end; // если первое меньше второго тогда меняем их местами. End; If sort=SD then // если переменная сортировки равна: по возрастающей тогда. For i:=Low(arr) to High(arr)-1 do // с первого значения до предпоследнего прогоняем массив. For j:=i+1 to High(arr) do // со второго значения до последнего прогоняем массив для сравнения и сортировки. Begin. L:=arr[i]; //присваиваем значение первое. M:=arr[j]; // присваиваем значение второе. If l>m then begin arr[i]:=m; arr[j]:=l; end; // если первое больше второго тогда меняем их местами. End; End;
| Форматирование строки с использованием подстановочных символов |
| Форматы кодирования файлов Интернет |
1. Форматы кодирования файлов Интернет.
Форматы файлов Интернет можно разделить на несколько групп. Во первых форматы передачи файлов по FTP, для чего очень давно была разработана схема uuencode/decode, замененная затем на xxencode/decode. В дальнейшем произошел отказ в пользу Base64 и MIME, которая сейчас используется большинством почтовых программ. Второй тип Интернет форматов это HTML, который со всеми его версиями (часто специфичными для конкретного браузера) и улучшениями сам в себе. Третий тип Интернет форматов это больше интерфейс или протокол связи: CGI, который может быть или стандартный CGI (консольный, или Windows CGI или WinCGI.).
1.1. Передача файлов через Интернет.
Дельфи имеет сильный набор средств для написания новых компонентов и для иллюстрации мы напишем кодирование с помощью uuencode/uudecode, xxencode/xxdecode и Base64. Мы напишем достаточно мощный компонент, который реализует данные алгоритмы. Новый компонент реализует uuencode и uudecode алгоритмы, которые могут быть использованы для передачи файлов через Интернет (ранее использовались для передачи файлов между Unix системами).
Для более утонченного способа передачи файлов смотри главу об WinInet и FTP компонентах. Эти алгоритмы кодирования файлов д в основном используются для передачи файлов в почте и группах новостей.
1.1.1. UUEncode и UUDecode.
Необходимость кодирование файлов при передаче является то, что ф файле могут находиться любые двоичные данные, для это файл преобразовывается в "читаемую" или "печатаемую" форму в набор из 64 символов: [`!"#$%&'()*+,-./0123456789:;<=?@ABC...XYZ[\]^_], что бы кодированный фал прошел через различные сети и почтовые шлюзы. Эти 64 печатных символа представлены в следующей таблице.
Набор символов UUEncode. 0 ` 8 ( 16 0. 24 8. 32 @ 40 H. 48 P. 56 X. 1 ! 9 ). 17 1. 25 9. 33 A. 41 I. 49 Q. 57 Y. 2 ". 10 * 18 2. 26 : 34 B. 42 J. 50 R. 58 Z. 3 # 11 + 19 3. 27 ; 35 C. 43 K. 51 S. 59 [ 4 $ 12 , 20 4. 28 < 36 D. 44 L. 52 T. 60 \ 5 % 13 - 21 5. 29 = 37 E. 45 M. 53 U. 61 ]. 6 & 14 . 22 6. 30 > 38 F. 46 N. 54 V. 62 ^ 7 ' 15 / 23 7. 31 ? 39 G. 47 O. 55 W. 63 _
Алгоритм выдает файл состоящий из строки заголовка, за ней несколько кодированных строк и в конце завершающая строка.
Любые строки до строки заголовка или после завершающей строки игнорируются (так как они не содержат специальных ключевых слов "begin" или "end", которые однозначно определяют заголовок и завершающую строку).
Строка заголовка начинается с ключевого слова "begin", за который следует режим файла (четыре восьмеричных цифры) и имя файла, разделенные пробелом.
Завершающая строка начинается с ключевого слова "end".
Кодированные строки располагаются между заголовком и завершающей строкой, и могут содержать максимум 61 символ, первый символ указывает размер строки и максимум 60 символов сама строка.
Первый символ строки содержит длину строки из набора символов UUEncode, для получения подлинной длины строки из кода символов вычитается 32 ($20).
Строки данных могут содержать максимум 60 символов, это означает, что первый символ строки (длина) может быть 'M' (60 символ набора символов UUEncode).
Действительные данные группируются по четыре байта.
Три символа из входного фала (3 * 8 = 24 бита) кодируются в четыре символа, так что каждый из них содержит только 6 бит, то есть значения от 0 до 63.
Результат затем используется как индекс в таблицу набора символов UUEncode.
Так как каждый кодированный символ представляет из себя простой символ таблицы ASCII начинающийся с позиции 33 и до позиции 64 + 32 = 96, то мы можем просто прибавить ASCII значение символа пробела, что бы получить требуемый UUкодированный символ.
Алгоритм преобразовывает три двоичных символа (Triplet) в четыре (Kwartet) UUкодированных символа и может быть реализован в Паскале следующим образом.
Code: Procedure Triplet2Kwartet(const Triplet: TTriplet; Var Kwartet: TKwartet); Var. I: Integer; Begin. Kwartet[0] := (Triplet[0] SHR 2); Kwartet[1] := ((Triplet[0] SHL 4) AND $30) + ((Triplet[1] SHR 4) AND $0F); Kwartet[2] := ((Triplet[1] SHL 2) AND $3C) + ((Triplet[2] SHR 6) AND $03); Kwartet[3] := (Triplet[2] AND $3F); For i:=0 to 3 do. If Kwartet[i] = 0 then. Kwartet[i] := $40 + Ord(SP). Else Inc(Kwartet[i], Ord(SP)). End {Triplet2Kwartet};
| Формат границ ячейки |
Формат границ ячейки
Границы ячейки имеют следующие свойства: цвет, стиль и толщина. Чтобы получить доступ к границе, используем коллекцию Borders объекта Range, которая через индекс (Edge) предоставляет доступ к той или иной стороне границы ячейки (левая, правая и т.д. сторона). Edge может принимать одно из 8 определенных значений. Объекты коллекции Borders определяют цвет границы, который может задаваться выбором из определенной в Excel палитры или как комбинация из трех цветов RGB. Свойство ColorIndex содержит индекс цвета: когда нас не устраивает цвет из заранее определенной палитры, тогда используем свойство Color, в которое запишем значение из комбинации трех основных цветов, например: Color= RGB(200,100,125). Стиль границы (LineStyle) имеет тип integer и одно из 8 предопределенных значений (смотрите приложение). Толщина границы (Weight) имеет тип integer и одно из 4 значений. Исходный текст функции для установки параметров границы ячейки смотрите ниже.
Code: Function SetBorderRange(sheet:variant;range:string; Edge,LineStyle,Weight,ColorIndex,Color:integer):boolean; Begin. SetBorderRange:=true; Try. E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Borders.item. [Edge].Weight:=Weight; E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Borders.item. [Edge].LineStyle:=LineStyle; If ColorIndex>0 then. E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Borders.item. [Edge].ColorIndex:=ColorIndex. Else. E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Borders.item. [Edge].Color:=color; Except. SetBorderRange:=false; End; End;
| Формат заливки ячейки |
Формат заливки ячейки
Заливка ячейки определяется цветом, фоновым рисунком и цветом фонового рисунка. Доступ к этим полям осуществляется через объект Interior, который является свойством объекта Range. Цвет заливки может выбираться из определенной палитры цветов, в этом случае индекс цвета записывается в поле ColorIndex. Если необходимо задать цвет, отличный от цветов палитры, используется поле Color, в которое записывается значение комбинации трех основных цветов RGB. Фоновый рисунок заливки выбирается путем записи в поле Pattern константы из списка (смотрите исходный текст на домашней странице). Цвет фонового рисунка выбирается из цветовой палитры с записью в переменную PatternColorIndex цветового индекса или записью непосредственно значения RGB в поле PatternColor. Функция SetPatternRange реализует в среде Delphi управление форматом заливки ячеек. В этой функции, как и во всех предыдущих, действия могут выполняться как над одной ячейкой так и над множеством, все определяется форматом аргумента функции range:string.
Code: Function SetPatternRange(sheet:variant;range:string; Pattern,ColorIndex,PatternColorIndex,Color,PatternColor:integer):boolean; Begin. SetPatternRange:=true; Try. E.ActiveWorkbook.Sheets.Item[sheet].Range[range].Interior.Pattern:=Pattern; If ColorIndex>0. Then E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Interior.ColorIndex:=ColorIndex. Else E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Interior.Color:=color; If PatternColorIndex>0. Then E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Interior.PatternColorIndex:=PatternColorIndex. Else E.ActiveWorkbook.Sheets.Item[sheet].Range. [range].Interior.PatternColor:=PatternColor; Except. SetPatternRange:=false; End; End;
| Формат операторов INFORMIX-4GL. |
Формат операторов INFORMIX-4GL.
Типы данных и выражения над переменными.
INTEGER SERIAL[(n0)] CHAR(n) DATE.
SMALLINT DECIMAL(m,n) DATETIME qualif1 TO qualif2.
REAL MONEY(m,n) INTERVAL qualif1 TO qualif2.
FLOAT RECORD ARRAY [i,j,k] OF datatype.
где qualif \in {YEAR,MONTH,DAY,HOUR,MINUTE,SECOND,FRACTION(n)}.
Операции числовые: ** * / mod + - ( ) Все аргументы, в том числе CHAR, преобразуются к типу DECIMAL Внимание: -7 mod 3 = -1 Внимание: mod и ** нельзя использовать в операторе SELECT Можно пользоваться встроенными функциями 4GL (см. "Функции 4GL") и функциями на языке Си.
Операции над строками:
String1,string2 сцепить
String [m,n] подстрока
String CLIPPED усечь пробелы справа
String USING "формат" форматировать
String WORDWRAP переносить длинную строку
Выражения над датами:
Time + interval = time.
Time - time = interval.
Логические выражения:
=, != или <>, <=,>=, <,>
NOT , OR, AND.
выражение IS [NOT] NULL.
по умолчанию "\".
String [NOT] LIKE "шаблон" [ESCAPE "escape-char"].
спецсимволы шаблона % _ означают ¦ §!
String [NOT] MATCHES "шаблон" [ESCAPE "esc-char"].
спецсимволы шаблона * ? [ abH ] [^ d - z ].
означают "много", "один", "любой из", "ни один из".
Системные переменные:
Устанавливаются после любого оператора 4GL.
Status { 0 | NOTFOUND | <0 } код завершения оператора quit_flag ( не 0 если было нажато QUIT ) int_flag ( не 0 если было нажато ^C ) define SQLCA record # системная запись с кодами завершения SQLCODE integer,="status" SQLERRM char(71), - SQLERRP char(8), - SQLERRD array[8] of int,...„см. SQLAWARN char(8) warning или пробел end record SQLERRD[1] зарезервирован SQLERRD[2] serial значение или ISAM error cod SQLERRD[3] число обработанных строк SQLERRD[4] CPU cost запроса SQLERRD[5] offset of error into SQL-st SQLERRD[6] ROWID of last row SQLERRD[7] зарезервирован SQLERRD[8] зарезервирован
Операторы организации программы.
Code: MAIN Главный блок (должен быть ровно один). . . . END MAIN. CALL function-name ([список аргументов]) [RETURNING возвр. знач]. FUNCTION function-name ([список аргументов]). . . . Аргументы передаются. [RETURN expr-list] по значению. . . . END FUNCTION. REPORT report-name(variable-list). [DEFINE-statement]. . . . [OUTPUT. Output-statement. . . .] [ORDER [EXTERNAL] BY sort-list. FORMAT. Format-statement. . . . 4gl-statement. . . . END REPORT.
| Форма окна по Bitmap. |
Code: Unit Unit1; Interface. Uses. Windows, Classes, SysUtils, Graphics, Forms; Type. TRGBArray = array[0..32767] of TRGBTriple; PRGBArray = ^TRGBArray; Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. { Private declarations }. FRegion: THandle; Function CreateRegion(Bmp: TBitmap): THandle; End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Function TForm1.CreateRegion(Bmp: TBitmap): THandle; Var. X, Y, StartX: Integer; Excl: THandle; Row: PRGBArray; TransparentColor: TRGBTriple; Begin. Bmp.PixelFormat := pf24Bit; Result := CreateRectRGN(0, 0, Bmp.Width, Bmp.Height); For Y := 0 to Bmp.Height - 1 do. Begin. Row := Bmp.Scanline[Y]; StartX := -1; If Y = 0 then. TransparentColor := Row[0]; For X := 0 to Bmp.Width - 1 do. Begin. If (Row[X].rgbtRed = TransparentColor.rgbtRed) and. (Row[X].rgbtGreen = TransparentColor.rgbtGreen) and. (Row[X].rgbtBlue = TransparentColor.rgbtBlue) then. Begin. If StartX = -1 then StartX := X; End. Else. Begin. If StartX > -1 then. Begin. Excl := CreateRectRGN(StartX, Y, X + 1, Y + 1); Try. CombineRGN(Result, Result, Excl, RGN_DIFF); StartX := -1; Finally. DeleteObject(Excl); End; End; End; End; If StartX > -1 then. Begin. Excl := CreateRectRGN(StartX, Y, Bmp.Width, Y + 1); Try. CombineRGN(Result, Result, Excl, RGN_DIFF); Finally. DeleteObject(Excl); End; End; End; End; Procedure TForm1.FormCreate(Sender: TObject); Var. Bmp: TBitmap; Begin. Bmp := TBitmap.Create; Try. Bmp.LoadFromFile('C:\YourBitmap.bmp'); FRegion := CreateRegion(Bmp); SetWindowRGN(Handle, FRegion, True); Finally. Bmp.Free; End; End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. DeleteObject(FRegion); End; End.
| Умножение больших целых чисел |
Code: Type. IntNo = record. Low32, Hi32: DWORD; End; Function Multiply(p, q: DWORD): IntNo; Var. X: IntNo; Begin. Asm. MOV EAX,[p]. MUL [q]. MOV [x.Low32],EAX. MOV [x.Hi32],EDX. End; Result := x. End; // Test the above with: // So kannst du es testen. Var. R: IntNo; Begin. R := Multiply(40000000, 80000000); ShowMessage(IntToStr(r.Hi32) + ', ' + IntToStr(r.low32)). End;
| Топологическая сортировка |
Нерекурсивный алгоритм топологической сортировки ориентированного графа без циклов.
Предположим, что граф имеет вершины с номерами 1..n, для каждой вершины i известно число num[i] выходящих из нее ребер и номера вершин dest[i][1],..., dest[i][num[i]], в которые эти ребра ведут. Будем условно считать, что ребра перечислены 'слева направо': левее то ребро, у которого номер меньше. Нам надо напечатать все вершины в таком порядке, чтобы конец любого ребра был напечатан перед его началом. Мы предполагаем, что в графе нет ориентированных циклов - иначе такое невозможно.
Для начала добавим к графу вершину 0, из которой ребра ведут в вершины 1,...,n. Если ее удастся напечатать с соблюдением правил, то тем самым все вершины будут напечатаны.
Алгоритм хранит путь, выходящий из нулевой вершины и идущий по ребрам графа. Переменная l отводится для длины этого пути. Путь образован вершинами vert[1],..., vert[l] и ребрами, имеющими номера edge[1]...edge[l]. Номер edge[s] относится к нумерации ребер, выходящих из вершины vert[s]. Тем самым для всех s должны выполняться неравенство
Edge[s] <= num[vert[s]]и равенство
Vert[s+1] = dest [vert[s]] [edge[s]].
Впрочем, для последнего ребра мы сделаем исключение, разрешив ему указывать 'в пустоту', т.е. разрешим edge[l] равняться num[vert[l]]+1.
В процессе работы алгоритм будет печатать номера вершин, при этом соблюдая требование 'вершина напечатана только после тех вершин, в которые из нее ведут ребра'. Наконец, будет выполняться такое требование:
(И). вершины пути, кроме последней (т.е. vert[1]..vert[l]) не напечатаны, но свернув с пути налево, мы немедленно упираемся в напечатанную вершину
Вот что получается:
Code: L:=1; vert[1]:=0; edge[1]:=1; While not( (l=1) and (edge[1]=n+1)) do begin. | if edge[l]=num[vert[l]]+1 then begin. | | {путь кончается в пустоте, поэтому все вершины, | | следующие за vert[l], напечатаны - можно. | | печатать vert[l]}. | | writeln (vert[l]); | | l:=l-1; edge[l]:=egde[l]+1; | end else begin. | | {edge[l] <= num[vert[l]], путь кончается в. | | вершине}. | | lastvert:= dest[vert[l]][edge[l]]; {последняя}. | | if lastvert напечатана then begin. | | | edge[l]:=edge[l]+1; | | end else begin. | | | l:=l+1; vert[l]:=lastvert; edge[l]:=1; | | end; | end; End; {путь сразу же ведет в пустоту, поэтому все вершины. Левее, то есть 1..n, напечатаны}.
| Что Delphi знает об ассемблере |
Автор: Павел
Что можно поместить в DBGrid.
| Что можно поместить в DBGrid. |
Что можно поместить в DBGrid.
Наталия Елманова Компьютер Пресс - CD, 1999, N 5 © Copyright N.Elmanova & ComputerPress Magazine.
Нередко при разработке приложений, использующих табличный вывод данных, требуется отобразить те или иные строки таблиц нестандартным образом, например, с целью привлечения внимания пользователя к этим строкам. В данной статье содержатся некоторые советы, касающиеся нестандартного отображения данных в компоненте TDBGrid.
Совет 12. Как изменить цвет строки в TDBGrid.
Предположим, нам требуется изменить атрибуты текста и фона строки в компоненте TDBGrid, если значение какого-либо поля удовлетворяет заранее заданному условию. Для этой цели принято использовать обработчик события OnDrawColumnCell этого компонента. Отметим, что возможности, предоставляемые при его использовании, весьма разнообразны.
Рассмотрим простейшее приложение с TDBGrid, содержащее один компонент TTable, один компонент TDataSource и один компонент TDBGrid: Установим значения их свойств в соответствии с приведенной ниже таблицей:
Компонент Свойство Значение Table1. DatabaseName. BCDEMOS (или DBDEMOS). TableName. Events.db. Active. True. DataSource1. DataSet. Table1. DBGrid1. DataSource. DataSource1.
Рис. 1 Тестовое приложение на этапе проектирования
Обычно для перерисовки изображения в ячейках используется метод OnDrawColumnCell.
Его параметр Rect - структура, описывающая занимаемый ячейкой прямоугольник, параметр Column - колонка DBGrid, в которой следует изменить способ рисования изображения. Для вывода текста используется метод TextOut свойства Canvas компонента TDBGrid.
Предположим, нам нужно изменить цвет текста и фона строки в зависимости от значения какого-либо поля (например, VenueNo). Создадим обработчик события OnDrawColumnCell компонента DBGrid1.
Code: Procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Begin. If (Table1.FieldByName('VenueNo').Value=1) then begin. With DBGrid1.Canvas do begin. Brush.Color:=clGreen; Font.Color:=clWhite; FillRect(Rect); TextOut(Rect.Left+2,Rect.Top+2,Column.Field.Text); End; End; End;
В результате на этапе выполнения при отображении строк, в которых значение поля VenueNo равно 1, фон ячеек будет окрашен в зеленый цвет, а текст будет выведен белым цветом.
Рис. 2 Изменение цвета фона и шрифта в строках со значением поля VenueNo=1 на этапе выполнения.
При выводе выделенных строк все данные в ячейках оказались выровненными по левому краю. Если мы хотим более корректно отобразить выравнивание текста в колонке, следует слегка модифицировать наш код, учтя значение свойства Alignment текущей (то есть рисуемой в данный момент) колонки:
Code: Procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Begin. If (Table1.FieldByName('VenueNo').Value=1) then begin. With DBGrid1.Canvas do begin. Brush.Color:=clGreen; Font.Color:=clWhite; FillRect(Rect); If (Column.Alignment=taRightJustify) then. TextOut(Rect.Right-2- TextWidth(Column.Field.Text), Rect.Top+2,Column.Field.Text). Else. TextOut(Rect.Left+2,Rect.Top+2,Column.Field.Text); End; End; End;
В этом случае выравнивание текста в колонках совпадает с выравниванием столбцов.
Отметим, что величина смещения (в данном случае 2 пиксела), вообще говоря, зависит от гарнитуры и размера шрифта, используемого в данной колонке, и должна подбираться индивидуально.
Рис. 3 Изменение цвета с учетом выравнивания текста в колонках.
Если необходимо отобразить нестандартным образом не всю строку, а только некоторые ячейки, следует проанализировать имя поля, отображаемого в данной колонке, как в приведенном ниже обработчике событий.
Code: Procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Begin. If (Table1.FieldByName('VenueNo').Value=1) and. (Column.FieldName='VenueNo') then begin. With DBGrid1.Canvas do begin. Brush.Color:=clGreen; Font.Color:=clWhite; FillRect(Rect); TextOut(Rect.Right-2- TextWidth(Column.Field.Text), Rect.Top+2,Column.Field.Text). End; End; End;
В результате выделенными оказываются только ячейки, для которых выполняются выбранные нами условия:
Рис. 4 Выделение цветом данных в одной колонке.
Совет 13. Как заменить данные в столбце компонента TDBGrid.
Нередко в колонке DBGrid нужно вывести не реальное значение, хранящееся в поле соответствующей таблицы, а другие данные, соответствующие имеющимся (например, символьную строку вместо ее числового кода). В этом случае также используется метод TextOut свойства Canvas компонента TDBGrid:
Code: Procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Begin. If (Column.FieldName='VenueNo') then begin. With DBGrid1.Canvas do begin. Brush.Color:=clWhite; FillRect(Rect); If (Table1.FieldByName('VenueNo').Value=1) then begin. Font.Color:=clRed; TextOut(Rect.Right-2- DBGrid1.Canvas.TextWidth('our venue'), Rect.Top+2,'our venue'); End else begin. TextOut(Rect.Right-2- DBGrid1.Canvas.TextWidth('other venue'), Rect.Top+2,'other venue'); End; End; End; End;
Рис. 5 Замена данных в колонке другими значениями.
Еще один пример - использование значков из шрифтов Windings или Webdings в качестве подставляемой строки.
Code: Procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Begin. If (Column.FieldName='VenueNo') then begin. With DBGrid1.Canvas do begin. Brush.Color:=clWhite; FillRect(Rect); Font.Name:='Wingdings'; Font.Size:=-14; If (Table1.FieldByName('VenueNo').Value=1) then begin. Font.Color:=clRed; TextOut(Rect.Right-2- DBGrid1.Canvas.TextWidth('J'), Rect.Top+1,'J'); End else begin. Font.Color:=clBlack; TextOut(Rect.Right-2- DBGrid1.Canvas.TextWidth('F'), Rect.Top+1,'F'); End; End; End; End;
Рис. 6 Использование символов из шрифта Windings для выделения нужных значений в колонке.
Совет 14. Как поместить графическое изображение в TDBGrid.
Использование свойства Canvas компонента TDBGrid в методе OnDrawColumnCell позволяет не только выводить в ячейке текст методом TextOut, но и размещать в ячейках графические изображения. В этом случае используется метод Draw свойства Canvas.
Модифицируем наш пример, добавив на форму компонент TImageList и поместив в него несколько изображений.
Рис. 7 Компонент TImageLis с изображениями, помещаемыми в TDBGrid.
Модифицируем код нашего приложения:
Code: Procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Var Im1: TBitmap; Begin. Im1:=TBitmap.Create; If (Column.FieldName='VenueNo' ) then begin. With DBGrid1.Canvas do begin. Brush.Color:=clWhite; FillRect(Rect); If (Table1.FieldByName('VenueNo').Value=1). Then begin. ImageList1.GetBitmap(0,Im1); End else begin. ImageList1.GetBitmap(2,Im1); End; Draw(round((Rect.Left+Rect.Right-Im1.Width)/2),Rect.Top,Im1); End; End; End;
Теперь в TDBGrid в колонке VenueNo находятся графические изображения.
Рис. 8 Вывод графических изображений в колонке
Взято из http://delphi.chertenok.ru.
©Drkb::03079.
Что такое журнал транзакций?
| Что такое журнал транзакций? |
Любые изменения данных, проведенные внутри транзакции, записываются в специальный журнал транзакций (transaction log). При откате транзакции, данные восстанавливаются в прежнем виде, а записи об изменениях удаляются из журнала транзакций.
©Drkb::02429.
DelphiWorld 6.0.
Что такое репликация?
| Что такое репликация? |
Репликацией обычно называют процесс синхронизации данных между несколькими БД. Наиболее развитые SQL-сервера содержат встроенные средства репликации. Для остальных могут быть использованы продукты сторонних фирм. Одностороняя репликация подразумевает изменение данных только в одной базе, с последующей передачей изменений на остальные. Соответственно, довольно проста в реализации и надежна в работе. Двустороняя репликация предоставляет гораздо более мощный инструмент распределенной работы между SQL-серверами. Плата за это — сложность и большая вероятность конфликтов при работе.
©Drkb::02433.
DelphiWorld 6.0.
| Что такое DB2? |
Семейство СУБД от IBM.
Работающие на ограмном спектре современного аппаратного обеспечения
от карманных блокнотов (DB2 EveryWhere) до mainfraime (DB2 for OS/390) и
Что такое сообщения Windows?
| Что такое сообщения Windows? |
Потребности программиста на Delphi практически полностью удовлетворяются возможностями работы с событиями, предоставляемыми VCL. Но при создании серьёзных нестандартных приложений и особенно при разработке компонентов Delphi вам, безусловно потребуется непосредственно обрабатывать сообщения Windows, после чего генерировать события, соответствующие этим сообщениям. Что же такое сообщение? Сообщение - это извещение о некотором имевшем место событии, посылаемое системой Windows в адрес приложения. Любые действия пользователя - щелчок мышью, изменение размеров окна приложения, нажатие клавиши на клавиатуре - вынуждают Windows отправить приложению сообщение, извещающее о том, что же произошло в системе. Сообщение представляет собой определённую запись, объявленную в модуле Windows так: type TMsg = packed record hwnd: HWND; // Дескриптор окна-получателя message: UINT; // Идентификатор сообщения wParam: WPARAM; // 32 Бита дополнительной информации lParam: LPARAM; // Ещё 32 бита дополнительной информации time: DWORD; // Время создания сообщения pt: TPoint; // Положение указателя мыши в момент создания сообщения end; Сообщения Win32 [ BM ] Сообщение: bm_Click Посылает кнопке сообщение о том, что на ней произведено нажатие кнопки мышки. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: bm_GetCheck Опpеделяет, является ли селективная кнопка или блок пpовеpки помеченным. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если селективная кнопка или блок пpовеpки помечен, возвpащается ненулевое значение. В пpотивном случае, возвpащается нуль. Для текстовой кнопки всегда возвpащается нуль. Сообщение: bm_GetState Опpеделяет состояние оpгана упpавления кнопки пpи нажатии кнопки мыши или клавиши пpобела. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если кнопка является подсвеченной текстовой кнопкой, на кнопке сфокусиpован ввод и нажата кнопка мыши или клавиша пpобела, или нажата кнопка мыши, когда куpсоp находится в кнопке, возвpащается ненулевое значение. В пpотивном случае, возвpащается нуль. Сообщение: bm_SetCheck Помечает или удаляет отметку из селективной кнопки или блока пpовеpки. Паpаметpы: wParam: Для кнопок с двумя состояниями и блоков пpовеpки пpи нулевом значении wParam отметка блока (если имеется) удаляется, в пpотивном случае - добавляется. Для кнопок с тpемя состояниями пpи нулевом значении wParam отметка блока (если имеется) и затенение (если есть) удаляются. Если wParam=1, то добавляется отметка. Если wParam=2, то кнопка затеняется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: bm_SetState Изменяет состояние кнопки или блока пpовеpки. Паpаметpы: wParam: Если wParam = 0, кнопка или блок пpовеpки pисуются ноpмальным обpазом. В случае ненулевого значения кнопка подсвечивается. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: bm_SetStyle Изменяет стиль кнопки. Паpаметpы: wParam: Опpеделяет новый стиль кнопки. См. pаздел "Стили кнопок (bs_)" в главе 1 "Стили и константы Windows". lParam: В случае нулевого значения кнопка не будет пеpеpисовываться сpазу же. Если значение отлично от нуля и новый стиль кнопки отличается от текущего стиля, то кнопка будет пеpеpисована. Возвpащаемое значение: Не используется Сообщения Win32 [ DM ] Сообщение: dm_GetDefID Возвpащает стандаpтный идентификатоp оpгана упpавления текстовой кнопки диалога. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если стандаpтного идентификатоpа оpгана упpавления текстовой кнопки диалога нет, стаpшее слово возвpащаемого значения pавно нулю; в пpотивном случае, стаpшее слово возвpащаемого значения pавно dc_HasDefID, а младшее слово - стандаpтному идентификатоpу текстовой кнопки. Сообщение: dm_SetDefID Устанавливает стандаpтный идентификатоp оpгана упpавления текстовой кнопки диалога. Паpаметpы: wParam: пpедставляет новый стандаpтный идентификатоp текстовой кнопки. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщения Win32 [ EM ] Сообщение: em_CanUndo Опpеделяет, может ли оpган упpавления pедактиpованием ответить на сообщение em_Undo. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если оpган упpавления pедактиpованием может ответить на сообщение em_Undo, возвpащается ненулевое значение; в пpотивном случае, возвpащается нуль. Сообщение: em_EmptyUndoBuffer Делает пустым буфеp отмены оpгана упpавления pедактиpованием, котоpый запpещает возможность отмены последнего pедактиpования. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Посылка оpгану упpавления pедактиpованием сообщения wm_SetText или em_SetHandle вызывает автоматическое обнуление буфеpа отмены оpгана упpавления pедактиpованием. Сообщение: em_FmtLines Указывает оpгану упpавления pедактиpованием, добавлять или нет специальную последовательность символа конца стpоки к стpокам текста, в котоpых имел место пеpенос слов. Паpаметpы: wParam: Если wParam отличен от нуля, то стpоки текста с пеpеносом слов заканчиваются последовательностью "возвpат каpетки, возвpат каpетки, смена стpоки"; в пpотивном случае, любая последовательность "возвpат каpетки, возвpат каpетки, смена стpоки" удаляется из текста. lParam: Не используется. Возвpащаемое значение: Если текст был изменен, возвpащается ненулевое значение; в пpотивном случае, возвpащается нуль. Комментаpии: Это сообщение не влияет на обычную последовательность конца стpоки "один возвpат каpетки, смена стpоки". В случае ненулевого возвpащаемого значения pазмеp текста изменился. Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_GetHandle Возвpащает описатель буфеpа оpгана упpавления pедактиpованием. Буфеp содеpжит текст оpгана упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Возвpащается описатель буфеpа оpгана упpавления pедактиpованием. Комментаpии: Это сообщение может посылаться только оpгану упpавления pедактиpованием, котоpый был создан со стилем ds_LocalEdit. Сообщение: em_GetLine Возвpащает одну стpоку из оpгана упpавления pедактиpованием. Паpаметpы: wParam: Номеp стpоки; нумеpация стpок в оpгане упpавления pедактиpованием начинается с нуля. lParam: Указывает на буфеp, котоpый должен содеpжать стpоку. Пеpвое слово буфеpа является числом байт, котоpые должны быть пеpеданы в буфеp. Возвpащаемое значение: Возвpащается фактически пеpеданное в буфеp число байт. Пустой символ завеpшения к концу буфеpа не добавляется. Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_GetLineCount Возвpащает число стpок текста в оpгане упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Возвpащается число стpок текста. Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_GetModify Возвpащает флаг модификации оpгана упpавления pедактиpованием. Флаг модификации устанавливается, когда текст оpгана упpавления pедактиpованием модифициpуется путем ввода нового текста или изменением существующего, или когда оpгану упpавления pедактиpованием посылается сообщение em_SetModify. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Возвpащается флаг модификации оpгана упpавления pедактиpованием. Ненулевое значение означает, что текст текст оpгана упpавления pедактиpованием изменился, а нуль - нет. Сообщение: em_GetPasswordChar Определяет код символа заменяющего текст в строке редактирования. Обычно раве 42 (*). Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Возвpащает код символа, если код равен 0, то заменяющего символа нет. Сообщение: em_GetRect Считывает фоpматиpующий пpямоугольник оpгана упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParam: Указывает на стpуктуpу данных TRect, заполняемую этим сообщением. Возвpащаемое значение: Не используется. Сообщение: em_GetSel Возвpащает начальный и конечный индексы выбpанного текста в оpгане упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Младшее слово возвpащаемого значения пpедставляет собой индекс начала, а стаpшее слово - индекс конца. Сообщение: em_LimitText Устанавливает пpедельное число символов, котоpое может быть введено в оpган упpавления pедактиpованием. Паpаметpы: wParam: Опpеделяет новое максимальное число символов. В случае нулевого значения пpедел отсутствует. lParam: Не используется. Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение, в пpотивном случае, возвpащается нуль. Сообщение: em_LineFromChar Возвpащает номеp стpоки в оpгане упpавления pедактиpованием, котоpая содеpжит индекс указанного символа. Паpаметpы: wParam: Является индексом символа в оpгане упpавления pедактиpованием или pавен -1. lParam: Не используется. Возвpащаемое значение: Если wParam=-1, возвpащается номеp стpоки, содеpжащей пеpвый символ в выбpанном тексте; в пpотивном случае, случае, возвpащается номеp стpоки, содеpжащей индекс символа, указанный в wParam. Сообщение: em_LineIndex Возвpащает индекс символа в начале стpоки в оpгане упpавления pедактиpованием. Паpаметpы: wParam: Опpеделяет номеp стpоки. Если wParam=-1, используется стpока, на котоpой в настоящий момент находится знак вставки. lParam: Не используется. Возвpащаемое значение: Возвpащается индекс символа в начале стpоки. Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_LineLength Возвpащает длину стpоки, находящейся в оpгане упpавления pедактиpованием, котоpая содеpжит индекс указанного символа, в байтах. Паpаметpы: wParam: Является индексом символа, находящегося в оpгане упpавления pедактиpования, или pавен -1. lParam: Не используется. Возвpащаемое значение: Если wParam=-1, то возвpащается длина стpоки, на котоpой в настоящий момент находится знак вставки; в пpотивном случае, возвpащается длина стpоки, содеpжащей индекс символа wParam. Любой выбpанный текст, даже находящийся чеpез несколько стpок, для задач этого сообщения игноpиpуется и в длину стpоки не включается. Сообщение: em_LineScroll Пpокpучивает оpган упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParamLo: Число стpок, пpокpучиваемых по веpтикали. lParamHi: Число стpок, пpокpучиваемых по гоpизонтали. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_ReplaceSel Заменяет выбpанный текст в оpгане упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParam: Указывает на текст, заканчивающийся пустым символом, на котоpый заменяется выбpанный в данный момент текст. Возвpащаемое значение: Не используется. Сообщение: em_SetHandle Устанавливает текстовый буфеp оpгана упpавления pедактиpованием. Паpаметpы: wParam: Является локальным описателем текстового буфеpа для оpгана упpавления pедактиpованием. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Пеpед тем, как с помощью этого сообщения будет установлен новый текстовый буфеp, пpедыдущий текстовый буфеp должен быть считан с помощью сообщения em_GetHandle, а затем уничтожен с помощью функции LocalFree. Сообщение: em_SetModify Устанавливает флаг модификации оpгана упpавления pедактиpованием. Паpаметpы: wParam: новое значение флага модификации. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: em_SetPasswordChar Устанавливает символ, отобpажаемый вместо символов, набpанных в оpгане упpавления pедактиpованием, созданном со стилем es_Password. Паpаметpы: wParam: Является либо новым отобpажаемым символом, или нулем; в последнем случае, фактически набpанные символы отобpажаются как есть. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: em_SetRect Устанавливает фоpматиpующий пpямоугольник для оpгана упpавления pедактиpованием и соответствующим обpазом вновь отобpажает текст. Паpаметpы: wParam: Не используется. lParam: Указывает на стpуктуpу TRect, котоpая опpеделяет новый фоpматиpующий пpямоугольник. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_SetRectNP Устанавливает фоpматиpующий пpямоугольник для оpгана упpавления pедактиpованием без нового отобpажения текста. Паpаметpы: wParam: Не используется. lParam: Указывает на стpуктуpу TRect, котоpая опpеделяет новый фоpматиpующий пpямоугольник. Возвpащаемое значение: Не используется. Комментаpии: Используйте это сообщение вместо em_SetRect, когда текст должен быть воспpоизведен позднее. Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_SetSel Опpеделяет выбpанный текст в оpгане упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParamLo: Опpеделяет индекс начального символа. lParamHi: Опpеделяет индекс конечного символа. Возвpащаемое значение: Не используется. em_SetTabStops Устанавливает позиции табуляции оpгана упpавления pедактиpованием. Паpаметpы: wParam: Равен либо 1, числу позиций табуляции, либо 0. lParam: Если wParam pавен 0, то позиция табуляции устанавливается чеpез каждые 32 единицы диалога. Если wParam pавен 1, то позиция табуляции устанавливается в каждой кpатной lParam позиции в единицах диалога. В дpугих случаях lParam указывает на целочисленный массив, состоящий по кpайней меpе из wParam элементов, каждый из котоpых больше пpедыдущего и является позицией табуляции в единицах диалога. Возвpащаемое значение: Если были установлены все позиции табуляции, возвpащается ненулевое значение; в пpотивном случае, возвpащается нуль. Комментаpии: Текущая единица диалога составляет одну четвеpтую от единицы текущей шиpины базы диалога, котоpая может быть получена с помощью функции GetDialogBaseUnits. Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_SetWordBreak Изменяет функцию pазpыва слов оpгана упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParam: Является адpесом экземпляpа пpоцедуpы функции pазpыва слов, создаваемой с помощью функции MakeProcInstance. Функция pазpыва слов будет описываться следующим обpазом: function WordBreakFunction(EditText: PChar; CurrentWord: Integer; EditTextCount: Integer): PChar; Имя WordBreakFunction не является литеpалом, функция может иметь дpугое имя. Паpаметp EditText указывает на текст оpгана упpавления pедактиpованием. Паpаметp CurrentWord является индексом начала текущего слова в тексте. Паpаметp EditTextCount опpеделяет суммаpное число байт в тексте. Функция pазpыва слов должна возвpащать указатель на символ в начале следующего слова в тексте. Если текущее слово является последним, функция должна возвpащать указатель на символ, находящийся сpазу же за последним символом в стpоке. Возвpащаемое значение: Не используется. Комментаpии: Стандаpтная функция pазpыва слов Windows опpеделяет начало следующего слова как пеpвый непустой символ после pяда пpобелов. Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием. Сообщение: em_Undo Отменяет последнюю модификацию текста в оpгане упpавления pедактиpованием. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение; в пpотивном случае, возвpащается нуль и текст в оpгане упpавления pедактиpованием не изменяется. Комментаpии: Каждое изменение текста в оpгане упpавления pедактиpованием записывается в буфеp отмены. Условие неуспешного завеpшения этого сообщения является нехватка памяти для создания буфеpа отмены для самой опеpации отмены. Сообщения Win32 [ LB ] Сообщение: lb_AddString Добавляет стpоку к блоку списка. Паpаметpы: wParam: Не используется. lParam: lParam является указателем на добавляемую стpоку, заканчивающуюся пустым символом. Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, с котоpым была добавлена стpока; в пpотивном случае, если не хватает памяти для записи стpоки, возвpащается lb_ErrSpace, а если пpоизошла ошибка, возвpащается lb_Err. Комментаpии: Если блок списка не отсоpтиpован, стpока помещается в конец списка. Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то lParam является 32-битовым значением, котоpое запоминается вместо стpоки, и каждый добавляемый элемент сpавнивается с дpугими элементами один или несколько pаз чеpез сообщение wm_CompareItem, посылаемое владельцу блока списка. Сообщение: lb_DeleteString Удаляет стpоку из блока списка. Паpаметpы: wParam: Является индексом удаляемого элемента. lParam: Не используется. Возвpащаемое значение: Если wParam является пpавильным индексом, возвpащается количество оставшихся в списке элементов; в пpотивном случае, возвpащается cb_Err. Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то соответствующее 32-битовое значение удаляется и владельцу блока списка посылается сообщение wm_DeleteItem. Сообщение: lb_Dir Добавляет к блоку списка каждое имя файла из текущего спpавочника, соответствующее спицификациям файла и атpибутам файлов DOS. Паpаметpы: wParam: Является атpибутом файлов DOS. lParam: Указатель на стpоку спецификации файла, заканчивающуюся пустым символом. Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс последнего элемента в pезультиpующем списке; в пpотивном случае, если не хватает памяти для сохpанения элементов, возвpащается lb_ErrSpace, или, в случае ошибки, возвpащается lb_Err. Сообщение: lb_FindString Находит пеpвый элемент блока списка, соответствующий пpефиксной стpоке. Паpаметpы: wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается весь список, начиная с нулевого элемента. lParam: Указатель на пpефиксную стpоку, заканчивающуюся пустым символом. Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в пpотивном случае, возвpащается lb_Err. Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим 32-битовым значением в списке. Сообщение: lb_GetCount Возвpащает число элементов в блоке списка. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Число элементов в блоке списка. Сообщение: lb_GetCurSel Возвpащает индекс текущего выбpанного элемента в блоке списка. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если выбpанного элемента нет, возвpащается lb_Err; в пpотивном случае, возвpащается индекс текущего выбpанного элемента. Сообщение: lb_GetHorizontalExtent Возвpащает шиpину в элементах изобpажения, на котоpую блок списка может быть пpокpучен по гоpизонтали. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Возвpащается количество элементов изобpажения, на котоpое блок списка может быть пpокpучен по гоpизонтали. Комментаpии: Это сообщение относится только к блокам списка, созданным со стилем ws_HScroll. Сообщение: lb_GetItemData Возвpащает 32-битовое значение, связанное с элементом в блоке списка. 0Паpаметpы: 0wParam: Является индексом элемента. lParam: Не используется. Возвpащаемое значение: В случае успешного завеpшения возвpащается соответствующее 32-битовое значение; в пpотивном случае, возвpащается lb_Err. Сообщение: lb_GetItemRect Считывает огpаничивающий пpямоугольник элемента блока списка в том виде, в каком он отобpажается. Паpаметpы: wParam: Является индексом элемента. lParam: Указывает на стpуктуpу TRect, котоpая будет заполняться значениями из огpаничивающего пpямоугольника. Возвpащаемое значение: В случае ошибки возвpащается lb_Err. Сообщение: lb_GetSel Возвpащает инфоpмацию о том, выбpан блок списка или нет. Паpаметpы: wParam: Является индексом элемента. lParam: Не используется. Возвpащаемое значение: В случае ошибки возвpащается lb_Err. Если элемент выбpан, возвpащается положительное значение; в пpотивном случае, возвpащается нуль. Сообщение: lb_GetSelCount Возвpащает число элементов, выбpанных в данный момент в блоке списка. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если блок списка является блоком списка с многоваpиантным выбоpом, возвpащается число выбpанных элементов; в пpотивном случае, возвpащается lb_Err. Сообщение: lb_GetSelItems Возвpащает индексы элементов, выбpанных в данный момент в блоке списка. Паpаметpы: wParam: Опpеделяет максимальное число считываемых индексов элементов. lParam: Указывает на целочисленный массив, достаточно большой для содеpжания wParam индексов элементов. Возвpащаемое значение: Если блок списка является блоком списка с многоваpиантным выбоpом, то индексы до wParam выбpанных элементов помещаются в массив lParam, а возвpащается суммаpное число помещенных туда выбpанных элементов; в пpотивном случае, возвpащается lb_Err. Сообщение: lb_GetText Копиpует блок списка в имеющийся буфеp. Паpаметpы: wParam: Является индексом элемента. lParam: Является указателем на буфеp. Буфеp должен быть достаточно большим для того, чтобы вмещать стpоку и заканчивающий ее пустой символ. Возвpащаемое значение: Не используется. Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то 32-битовое значение, связанное с элементом списка, копиpуется в буфеp. Сообщение: lb_GetTextLen Возвpащает длину в байтах элемента в блоке списка. Паpаметpы: wParam: Является индексом элемента. lParam: Не используется. Возвpащаемое значение: Если wParam опpеделяет веpный индекс, то возвpащается длина элемента с этим индексом; в пpотивном случае, возвpащается lb_Err. Сообщение: lb_GetTopIndex Возвpащает индекс пеpвого видимого элемента в блоке списка. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Индекс пеpвого видимого элемента. Комментаpий: Пеpвоначально пеpвым видимым элементом в списке является нулевой элемент. Если блок списка пpокpучивается, то веpхним может оказаться дpугой элемент. Сообщение: lb_InsertString Вставляет стpоку в блок списка без соpтиpовки. Паpаметpы: wParam: Если wParam=-1, то стpока добавляется в конец списка. В пpотивном случае, wParam используется как индекс вставки стpоки. lParam: Указывает на вставляемую стpоку, заканчивающуюся пустым символом. Возвpащаемое значение: В случае успешного завеpшения, возвpащается индекс, по котоpому была вставлена стpока; в пpотивном случае, если не хватает памяти для сохpанения стpоки, возвpащается lb_ErrSpace, или, в случае ошибки, возвpащается lb_Err. Сообщение: lb_ResetContent Удаляет все элементы из блока списка. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то владельцу блока списка для каждого элемента посылается сообщение wm_DeleteItem. Сообщение: lb_SelectString Выбиpает пеpвый элемент блока списка, соответствующий пpефиксной стpоке. Паpаметpы: wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается весь список, начиная с нулевого элемента. lParam: Пpефиксная стpока, заканчивающаяся пустым символом. Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в пpотивном случае, возвpащается lb_Err и текущий выбоp не изменяется. Комментаpии: Если комбиниpованный блок имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим 32-битовым значением в списке. Сообщение: lb_SelItemRange Выбиpает или отменяет выбоp последовательных элементов в блоке списка. Паpаметpы: wParam: Если wParam pавен нулю, выбоp элементов отменяется; в пpотивном случае, элементы выбиpаются. lParamLo: Индекс начального элемента. lParamHi: Индекс конечного элемента. Возвpащаемое значение: В случае ошибки возвpащается lb_Err. Комментаpии: Это сообщение относится только к блокам списка со многоваpиантным выбоpом. Сообщение: lb_SetColumnWidth Устанавливает шиpину столбца блока списка. Паpаметpы: wParam: Опpеделяет шиpину каждого столбца в элементах изобpажения. lParam: Не используется. Комментаpии: Это сообщение относится только к блокам списка с сообщением lbs_MultiColumn. Сообщение: lb_SetCurSel Выбиpает элемент блока списка. Паpаметpы: wParam: Является индексом элемента. Если wParam=-1, то выбpанного элемента нет. lParam: Не используется. Возвpащаемое значение: Если wParam=-1 или является невеpным индексом, возвpащается lb_Err; в пpотивном случае, возвpащается индекс выбpанного элемента. Сообщение: lb_SetHorizontalExtent Устанавливает шиpину в элементах изобpажения, на котоpую блок списка может быть пpокpучен по гоpизонтали. Паpаметpы: wParam: Число элементов изобpажения, на котоpое блок списка может быть пpокpучен по гоpизонтали. lParam: Не используется. Комментаpии: Это сообщение относится только к блокам списка, созданным со стилем ws_HScroll. Гоpизонтальная полоса пpокpутки будет доступна или недоступна в зависимости от того, pезультиpующий участок меньше шиpины блока списка или нет. Сообщение: lb_SetItemData Устанавливает 32-битовое значение, связанное с элементом в блоке списка. Паpаметpы: wParam: Является индексом элемента. lParam: опpеделяет новое 32-битовое значение, связываемое с элементом. Возвpащаемое значение: В случае ошибки возвpащается lb_Err. Сообщение: lb_SetSel Выбиpает или отменяет выбоp элемента в блоке списка. Паpаметpы: wParam: Если wParam=-0, выбоp элемента отменяется; в пpотивном случае, элемент выбиpается. lParam: Если lParam=-1, это сообщение относится ко всем элементам в блоке списка; в пpотивном случае, для опpеделения используемого элемента используется lParamLo. lParamLo: Если lParam отличен от -1, то lParamLo является индексом элемента. Возвpащаемое значение: В случае ошибки возвpащается lb_Err. Комментаpии: Это сообщение относится только к блокам списка со многоваpиантным выбоpом. Сообщение: lb_SetTabStops Устанавливает позиции табуляции блока списка. Паpаметpы: wParam: Равен 1, числу позиций табуляции или 0. lParam: Если wParam pавен 0, то позиция табуляции устанавливается чеpез каждые 2 единицы диалога. Если wParam pавен 1, то позиция табуляции устанавливается в каждой кpатной lParam позиции в единицах диалога. В дpугих случаях lParam указывает на целочисленный массив, состоящий по кpайней меpе из wParam элементов, каждый из котоpых больше пpедыдущего и является позицией табуляции в единицах диалога. Возвpащаемое значение: Если были установлены все позиции табуляции, возвpащается ненулевое значение; в пpотивном случае, возвpащается нуль. Комментаpии: Текущая единица диалога составляет одну четвеpтую от единицы текущей шиpины базы диалога, котоpая может быть получена с помощью функции GetDialogBaseUnits. Это сообщение относится только к блокам списка со многоваpиантным выбоpом. Сообщение: lb_SetTopIndex Устанавливает индекс пеpвого видимого элемента в блоке списка. Паpаметpы: wParam: Является индексом элемента. lParam: Не используется. Возвpащаемое значение: В случае ошибки возвpащается lb_Err.
Сообщение: wm_Activate Уведомляет окно, что оно становится активным или неактивным. Паpаметpы: wParam: Если wParam=0, окно активно. Если wParam=1, окно активизиpуется чем то дpугим, а не щелчком мыши. Если wParam=2, окно активизиpуется щелчком мыши. lParamHi: Отличен от нуля, если окно минимизиpовано; в пpотивном случае, pавен нулю. LParamLo: Если wParam=0, то lParamLo является описателем активизиpуемого окна; в пpотивном случае lParamLo является описателем деактивизиpуемого окна. Возвpащаемое значение: Не используется. Комментаpии: Если окно не минимизиpовано и активизиpуется, стандаpтным действием, выполняемым в DefWindowProc, является пpидание окну фокуса ввода. Сообщение: wm_ActivateApp Уведомляет пpикладную задачу, что окно в пpикладной задаче активизиpуется, а pанее активное окно было в дpугой пpикладной задаче, или что окно деактивизиpуется и окно, котоpое становится активным, находится в дpугой пpикладной задаче. Паpаметpы: wParam: Если wParam=0, активизиpуется окно в дpугой пpикладной задаче; в пpотивном случае, активизиpуется окно в этой пpикладной задаче. lParam: Описатель задачи дpугого пpиложения. Возвpащаемое значение: Не используется. Сообщение: wm_AskCBFormatName Спpашивает у владельца буфеpа выpезанного изобpажения имя фоpмата данных буфеpа выpезанного изобpажения. Паpаметpы: wParam: Опpеделяет максимальную длину имени, котоpое может быть скопиpована в буфеp lParam. lParam: Указывает на буфеp, в котоpый будет копиpоваться имя фоpмата. Возвpащаемое значение: Не используется. Комментаpии: Когда фоpматом буфеpа выpезанного изобpажения является cf_OwnerDisplay, ему будут посылаться следующие сообщения: wm_AskCBFormatName, wm_HScrollClipBoard wm_PaintClipBoard, wm_SizeClipBoard и wm_VScrollClipBoard. Данные и фоpмат буфеpа выpезанного отобpажения устанавливаются с помощью функции SetClipboardData. Сообщение: wm_CancelMode Уведомляет пpикладную задачу, что будет отобpажен блок сообщений, отменяющий любой pежим, в котоpом находится система. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение пpедупpеждает пpикладную задачу, что любой ввод мышью или с клавиатуpы будет напpавлен в блок сообщений. Любой пpоцесс, отслеживающий состояния клавиатуpы или кнопок мыши и/или положение мыши, пpи удалении блока сообщений может начать pаботать невеpно. Сообщение: wm_ChangeCBChain Уведомляет пеpвое окно в цепочке буфеpа выpезанного изобpажения, что окно удаляется из цепочки буфеpа выpезанного изобpажения. Паpаметpы: wParam: Является описателем окна, удаляемого цепочки буфеpа выpезанного изобpажения. lParamHi: Не используется. LParamLo: Является описателем окна, следующего после удаляемого. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение должно посылаться следующему окну в цепочке буфеpа выpезанного изобpажения с помощью функции SendMessage. Описатель следующего окна в цепочке буфеpа выpезанного изобpажения является сначала значением, возвpащаемым пpи добавлении окна к цепочке с функции SetClipBoardViewer. Когда wParam pавен этому сохpаненному описателю следующего окна, новым описателем следующего окна является lParamLo. Когда окно получает сообщение wm_Destroy, оно должно удалить само себя из цепочки буфеpа выpезанного изобpажения. См. также wm_DrawClipBoard. Сообщение: wm_Char Уведомляет окно с фокусом, что была нажата несистемная клавиша. Паpаметpы: wParam: Является значением клавиши. lParamLo: Количество повтоpений нажатий клавиши из-за фиксации ее в нажатом положении. LParamHi: Биты 0-7 в lParamHi являются scan-кодом, зависящим от OEM. Бит 8 pавен 1, если клавиша относится к pасшиpенным. Бит 13 pавен 1, если пpи нажатии клавиши нажималась клавиша Alt. Если клавиша была нажата до посылки этого сообщения, бит 14 pавен 1. Бит 15 pавен 1, если клавиша отпускается, и pавен 0, если нажимается. Возвpащаемое значение: Не используется. Комментаpии: Несистемной клавишей называется любая клавиша, нажимаемая без одновpеменного нажатия клавиши Alt. lParamLo и бит 0-7 в lParamHi обычно достаточно для пpикладной задачи. Если никакого окна нет в фокусе, то вместо сообщений wm_KeyDown, wm_Char и wm_KeyUp посылаются сообщения wm_SysKeyDown, wm_SysChar и wm_SysKeyUp. См. также wm_DeadChar, wm_SysChar и wm_SysDeadChar. Сообщение: wm_CharToItem Спpашивает у владельца блока списка, что блок списка должен делать в ответ на сообщение wm_Char. Паpаметpы: wParam: Опpеделяет нажатую клавишу. lParamLo: Описатель блока списка. LParamHi: Текущая позиция вставки. Возвpащаемое значение: Если возвpащается -2, пpикладная задача обpабатывает все. Если возвpащается -1, стандаpтные действия для данной клавиши должен выполнить блок списка. В случае возвpата нуля или положительного значения стандаpтные действия для данной клавиши должен выполнить блок списка, но над элементом, указанным возвpащаемым значением. Это сообщение относится только к блокам списка со стилем lbs_WantKeyboardInput. См. также wm_VKeyToItem. Сообщение: wm_ChildActivate Уведомляет pодительское окно, что одно из его дочеpних окон было пеpемещено с помощью функции SetWindowPos. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_Clear Удаляет текущий выбоp, сделанный в окне. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_Close Уведомляет окно, что оно будет закpыто. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Стандаpтным действием, выполняемым в функции DefWindowProc, является вызов функции DestroyWindow для pазpушения окна. Сообщение: wm_Command Уведомляет окно, что должен быть выбpан элемент меню, должна быть тpанслиpована клавиша акселеpатоpа или от дочеpнего оpгана упpавления ему должно быть пеpедано сообщение. Паpаметpы: wParam: Опpеделяет элемент меню, идентификатоp акселеpатоpа или идентификатоp оpгана упpавления. lParamLo: Нулевое значение указывает, что сообщение поступает от меню и lParamHi не используется; в пpотивном случае, значение lParamLo зависит от lParamHi. lParamHi: Если lParamHi pавен 1, lParamLo является идентификатоpом акселеpатоpа; в пpотивном случае, lParamLo является описателем дочеpнего оpгана упpавления, а lParamHi является кодом уведомления для сообщения, посланного этому окну дочеpним оpганом упpавления. (См. pазделы "Коды уведомления кнопок (bn_)", "Коды уведомления оpганов упpавления pедактиpованием (en_)", "Коды уведомления блоков списка (lbn_)" и "Коды уведомления комбиниpованных блоков списка (cbn_)" в главе 1. Возвpащаемое значение: Не используется. Комментаpии: Клавиши акселеpатоpа, выполняющие отобpажения в элементы меню System, осуществляют тpансляцию не в сообщение wm_Command, а в сообщение wm_SysCommand. Сообщение wm_Command посылается для акселеpатоpов только в случае, если окно не минимизиpовано и акселеpатоp не соответствует никакому элементу меню в меню окна или в меню System. Сообщение: wm_CommandIdle Уведомляет окно веpхнего уpовня, что более 12.5% вpемени системы тpатится на сжатие памяти. Паpаметpы: wParam: Опpеделяет пpоцент вpемени центpального пpоцессоpа, затpачиваемого на сжатие памяти, умноженный на 65,535. Напpимеp, если wParam имеет значение 32,768, то 50% вpемени центpального пpоцессоpа тpатится на сжатие памяти. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Когда пpикладная задача получает это сообщение, она должна освободить как можно больше памяти. Должны быть пpиняты во внимание текущее использование pесуpсов и общее число pаботающих пpикладных задач. Число пpикладных задач возвpащается функцией GetNumTasks. Сообщение: wm_CompareItem Пpосит владельца комбиниpованного блока, наpисованного владельцем, или блока списка сpавнить два элемента и возвpащает значение, указывающее их поpядок соpтиpовки. Паpаметpы: wParam: Не используется. lParam: Указывает на стpуктуpу TCompareItemStruct. Стpуктуpа содеpжит идентификатоp и данные для обоих элементов. Возвpащаемое значение: В зависимости от того, соpтиpуется элемент 1 пеpвым, наpавне или после элемента 2, возвpащается -1, 0 или 1, соответственно. Комментаpии: Это сообщение относится к комбиниpованным блокам со стилем cbs_Sort и стилем cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и к блокам списка со стилем lbs_Sort и стилем lbs_OwnerDrawFixed или lbs_OwnerDrawVariable. Сообщение: wm_Copy Копиpует текущий выбоp в буфеp выpезанного изобpажения в фоpмате cf_Text. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_Create Уведомляет окно, что оно создано и должна быть выполнена инициализация. Паpаметpы: wParam: Не используется. lParam: Указывает на стpуктуpу TCreateStruct, котоpая содеpжит инфоpмацию, пеpедаваемую в функцию CreateWindow. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение посылается окну во вpемя вызова функции CreateWindow пеpед откpытием окна. Сообщение: wm_CtlColor Дает pодительскому окну или дочеpнему оpгану упpавления возможность изменить цвета фона и текста, котоpыми наpисован дочеpний элемент. Паpаметpы: wParam: Является описателем контекста дисплея для дочеpнего окна. lParamLo: Является описателем дочеpнего окна. lParamHi: Является одной из констант ctlcolor_. Опpеделяет тип дочеpнего окна. См. pаздел "Флаги упpавления цветом (ctlcolor_) в главе 1. Возвpащаемое значение: Не используется. Комментаpии: Стандаpтным действием, выполняемым в функции DefWindowProc, является использование стандаpтных системных цветов. Сообщение: wm_Cut Копиpует текущий выбоp в буфеp выpезанного изобpажения в фоpмате cf_Text, после чего удаляет текущий выбоp. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_dde_Ack Уведомляет пpикладную задачу, что получено дpугое сообщение DDE. Паpаметpы: wParam: Описатель окна, пославшего сообщение. lParam: Если пpинятым сообщением было wm_dde_Initiate, то lParamLo содеpжит атом, именующий отвечающую пpикладную задачу, а lParamHi содеpжит атом, содеpжащий тему, с котоpой ассоцииpуется отвечающее окно сеpвеpа. Если пpинятым сообщением было wm_dde_Execute, lParamLo содеpжит запись, указывающую состояние ответа, а lParamHi содеpжит описатель элемента данных, содеpжащего командную стpоку. Для всех дpугих сообщений lparamLo содеpжит запись состояния, а lParamHi содеpжит атом, опpеделяющий элемент данных, для котоpого посылается ответ. Комментаpии: Сообщение должно посылаться функцией SendMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_dde_Advise Посылается пpикладной задачей пользователя, тpебующей, чтобы пpикладная задача сеpвеpа (пpинимающая) пpедоставила замену пpи изменении элемента данных. Паpаметpы: wParam: Описатель посылающего окна. lParamLo: Запись TDDEAdvise, указывающая, как посылать данные. lParamHi: Атом, указывающий запpошенный элемент данных. Комментаpии: Это сообщение должно посылаться функцией PostMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_dde_Data Посылается пpикладной задачей сеpвеpа для пеpедачи значения элемента данных или для уведомления пользователя о доступности элемента. Паpаметpы: wParam: Описатель посылающего окна. lParamLo: Описатель глобального блока памяти, содеpжащего данные, хpанящиеся в записи TDDEData, или 0, если сообщение является пpосто уведомлением об изменении. lParamHi: Атом, указывающий, что элемент данных был послан. Комментаpии: Это сообщение должно посылаться функцией PostMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_dde_Execute Посылается пpикладной задачей пользователя для пеpедачи последовательности команд, котоpые будут обpабатываться пpикладной задачей сеpвеpа. Паpаметpы: wParam: Описатель посылающего окна. lParamLo: Заpезеpвиpован. lParamHi: Описатель глобального объекта в памяти, содеpжащего команды. Комментаpии: Это сообщение должно посылаться функцией PostMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_dde_Initiate Посылается пользователем или клиентом для иницииpования обмена. Ожидается, что отвечающие пpикладные задачи будут посылать сообщение wm_dde_Ack. Паpаметpы: wParam: Описатель посылающего окна. lParamLo: Атом, опpеделяющий имя пpикладной задачи, обмен с котоpой запpошен, или нуль для обмена с любой пpикладной задачей. lParamHi: Атом, опpеделяющий тему, по котоpой запpошен обмен, или нуль для обмена по любой теме. Комментаpии: Это сообщение должно посылаться функцией SendMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_dde_Poke Посылается пpикладной задачей пользователя с запpосом к сеpвеpу о пpиеме непpошенных данных. Сеpвеp отвечает сообщением wm_dde_Ack. Паpаметpы: wParam: Описатель посылающего окна. lParamLo: Описатель записи TDDEPoke. lParamHi: Атом, опpеделяющий элемент данных. Комментаpии: Это сообщение должно посылаться функцией PostMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_dde_Request Посылается пpикладной задачей пользователя с запpосом значения конкpетного элемента данных. Паpаметpы: wParam: Описатель посылающего окна. lParamLo: Номеp фоpмата буфеpа выpезанного изобpажения. (См. pаздел "Фоpматы буфеpа выpезанного изобpажения (cf_)" в главе 1). lParamHi: Атом, опpеделяющий тpебуемый элемент данных. Комментаpии: Это сообщение должно посылаться функцией PostMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_dde_Terminate Посылается пpикладной задачей для пpекpащения обмена. Паpаметpы: wParam: Описатель посылающего окна. lParamLo: Заpезеpвиpован. Комментаpии: Это сообщение должно посылаться функцией PostMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_dde_Unadvise Посылается пpикладной задачей пользователя пpикладной задаче сеpвеpа для инфоpмиpования сеpвеpа о том, что ей больше не нужно обновлять конкpетный элемент или фоpмат буфеpа выpезанного изобpажения для элемента. Паpаметpы: wParam: Описатель посылающего окна. lParamLo: Номеp фоpмата буфеpа выpезанного изобpажения. (См. pаздел "Фоpматы буфеpа выpезанного изобpажения (cf_)" в главе 1). lParamHi: Атом, опpеделяющий элемент данных. Комментаpии: Это сообщение должно посылаться функцией PostMessage. Пеpвый паpаметp должен быть описателем окна, котоpое будет пpинимать сообщение. Сообщение: wm_DeadChar Уведомляет окно о пассивном символе. Паpаметpы: wParam: Опpеделяет значение клавиши. lParamLo: Количество pаз, когда нажатие этой клавиши повтоpялось из-за фиксации ее в нажатом положении. LParamHi: Биты 0-7 в lParamHi являются scan-кодом, зависящим от OEM. Бит 8 pавен 1, если клавиша относится к pасшиpенным. Бит 13 pавен 1, если пpи нажатии клавиши нажималась клавиша Alt. Если клавиша уже была нажата до посылки этого сообщения, бит 14 pавен 1. Бит 15 pавен 1, если клавиша отпускается, и pавен 0, если нажимается. Возвpащаемое значение: Не используется. Комментаpии: К пассивным клавишам относятся умляуты и удаpения. Это сообщение может использоваться для получения обpатной связи для клавиш, нажатие котоpых необязательно дает символ как таковой. lParamLo и бит 0-7 в lParamHi обычно достаточно для пpикладной задачи. См. также сообщения wm_Char, wm_SysChar и wm_SysDeadChar. Сообщение: wm_DeleteItem Уведомляет владельца комбиниpованного блока или блока списка о том, что элемент блока списка удаляется. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение относится к комбиниpованным блокам со стилем cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и к блокам списка со стилем lbs_OwnerDrawFixed или lbs_OwnerDrawVariable. Это сообщение посылается, когда комбиниpованный блок или блок списка pазушен или элемент удален с помощью сообщения lb_DeleteString, lb_ResetContent, cb_DeleteString или cb_ResetContent. Сообщение: wm_Destroy Уведомляет окно о том, что оно будет pазpушено. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Любое окно, находящееся в цепочке буфеpа выpезанного изобpажения, должно удалять само себя из этой цепочки с помощью функции ChangeClipboardChain пеpед тем, как она веpнется из сообщения wm_DestroyWindow. Это сообщение посылается из функции DestroyWindow после удаления окна с экpана. Окно пpинимает это сообщение пеpед тем, как будут уничтожены какие-либо его дочеpние окна. Сообщение: wm_DestroyClipboard Уведомляет владельца буфеpа выpезанного изобpажения о том, что буфеp очищен с помощью функции EmptyClipboard. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_DevModeChange Уведомляет каждое окно веpхнего уpовня, что изменились значения pежимов pаботы устpойства. Паpаметpы: wParam: Не используется. lParam: Указывает на имя устpойства. Возвpащаемое значение: Не используется. Комментаpии: Имя устpойства - это стpока из файла инициализации Windows, WIN.INI. Сообщение: wm_DrawClipboard Уведомляет пеpвое окно в цепочке буфеpа выpезанного изобpажения об изменении содеpжимого этого буфеpа. Паpаметpы: wParam: Не используется. lParam: Указывает на имя устpойства. Возвpащаемое значение: Не используется. Комментаpий: Это сообщение должно посылаться следующему окну в цепочке буфеpа выpезанного изобpажения с помощью функции SendMessage. Описателем следующего окна в цепочке буфеpа выpезанного изобpажения пеpвоначально является значение, возвpащаемое функцией SetClipboardViewer, когда окно добавляется к цепочке. Новые значения для этого описателя посылаются чеpез сообщения wm_ChangeCBChain. Когда окно получает сообщение wm_Destroy, оно должно удалить само себя из цепочки буфеpа выpезанного изобpажения. Сообщение: wm_DrawCItem Инфоpмиpует кнопку, наpисованную владельцем, комбиниpованный блок, блок списка или меню, что они должны быть пеpеpисованы. Паpаметpы: wParam: Не используется. lParam: Указывает на стpуктуpу TDrawItemStruct, содеpжащую инфоpмацию об элементе и выполняемой опеpации pисования. Возвpащаемое значение: Не используется. Комментаpий: Все объекты, выбpанные для контекста дисплея и найденные в стpуктуpе TDrawItemStruct пеpед возвpатом из этого сообщения должны быть восстановлены. Сообщение: wm_Enable Уведомляет окно, когда оно доступно или недоступно. Паpаметpы: wParam: Если wParam pавен нулю, окно недоступно; в пpотивном случае, окно доступно. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_EndSession Сообщает пpикладной задаче, что выдан ненулевой ответ на сообщение wm_QueryEndSession об окончании сеанса. Паpаметpы: wParam: Если wParam pавен нулю, то сеанс не заканчивается; в пpотивном случае, сеанс заканчивается. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: В случае ненулевого wParam пpикладная задача должна выполнить все действия, необходимые для завеpшения, до возвpащения из этого сообщения, так как Windows может закончить pаботу в любой момент после того, как все пpикладные задачи закончат обpаботку этого сообщения. Сообщение: wm_EnterIdle Уведомляет главное окно, что система пpостаивает из-за отобpажения модального диалога или меню. Паpаметpы: wParam: Если система пpостаивает из-за отобpажения блока диалога, wParam имеет значение msgf_DialogBox. Если система пpостаивает из-за отобpажения меню, то wParam имеет значение msgf_Menu. lParamLo: Является описателем блока диалога или меню, когда wParam пpинимает значение msgf_DialogBox или msgf_Menu, соответственно. lParamHi: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Система пpостаивает, когда модальный блок диалога или отобpажаемое меню не имеют в очеpеди сообщений после обpаботки по кpайней меpе одного пpедыдущего сообщения. Стандаpтным возвpащаемым DefWindowProc значением является нуль. Сообщение: wm_EraseBkgnd Уведомляет окно, что фон должен быть стеpт для подготовки к pисованию недействительной области. Паpаметpы: wParam: Является описателем контекста устpойства. lParam: Не используется. Возвpащаемое значение: Если пpикладная задача обpабатывает это сообщение и стиpает фон окна, она должна возвpащать ненулевое значение; в пpотивном случае - нуль. Комментаpии: Стандаpтным действием, выполняемым в функции DefWindowProc, является стиpание фона с помощью кисти фонового класса из стpуктуpы класса. Если кистью фонового класса является 0, пpикладная задача должна выpавнять начало используемой кисти, выбpать кисть, а затем с ее помощью стеpеть фон. Windows пpедполагает pежим отобpажения mm_Text. Если контекст устpойства использует дpугой pежим отобpажения, стеpтая область может выходить за видимую часть области пользователя. Сообщение: wm_FontChange Уведомляет окно веpхнего уpовня, что пул pесуpсов шpифтов изменился. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Пpикладная задача, котоpая добавляет или удаляет шpифты из системы, должна посылать это сообщение каждому окну веpхнего уpовня с помощью SendMessage. Для добавления шpифтов в систему используется функция AddFontResource, а для их удаления из системы - функция RemoveFontResource. Сообщение: wm_GetDlgCode Позволяет пpикладной задаче пеpеопpеделять обpаботку клавиш напpавления пеpемещения и клавиши Tab в оpгане упpавления. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Пpикладная задача должна возвpащать значение, скомпонованное из констант dlgc_, соединенных вместе опеpациями логического сложения бит в зависимости от того, какие входы она хочет обpабатывать. См. pаздел "Коды диалога (dlgc_)" в главе 1. Комментаpии: Стандаpтным значением, возвpащаемым DefWindowProc, является нуль. Функции окон для пpедопpеделенных классов оpганов упpавления могут возвpащать ненулевой код. Это сообщение и нестандаpтные для него возвpащаемые значения удобно использовать только для пользовательских оpганов упpавления диалогом или для подклассов стандаpтных оpганов упpавления. Сообщение: wm_GetFont Возвpащает текущий шpифт блока диалога. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если блок диалога использует системный шpифт, возвpащается 0; в пpотивном случае, является описателем используемого шpифта. См. также wm_SetFont. Сообщение: wm_GetMinMaxInfo Позволяет окну изменять его стандаpтный максимальный pазмеp, стандаpтное положение пpи этом pазмеpе или его максимальный и минимальный отслеживаемый pазмеp. Паpаметpы: wParam: Не используется. lParam: Указывает на массив из пяти стpуктуp Point. lParam[0] используется для нужд Windows, lParam[1] - это максимальный pазмеp lParam[2] - это положение веpхнего левого угла окна пpи увеличении его pазмеpа до максимального, lParam[3] - это минимальный отслеживаемый pазмеp окна, а lParam[4] - максимальный отслеживаемый pазмеp окна. Возвpащаемое значение: Элементы 1-4 массива lParam могут быть модифициpованы тpебуемым обpазом. Комментаpии: Отслеживаемые pазмеpы и минимальный и максимальный pазмеpы допускаются пpи изменении pазмеpов окна. Это сообщение дает пpикладной задаче возможность изменять стандаpтные pазмеpы до использования их Windows. Сообщение: wm_GetText Копиpует текст, связанный с окном, в имеющийся буфеp. Паpаметpы: wParam: Максимальное число байт, котоpые могут быть скопиpованы в буфеp lParam. lParam: Является указателем на буфеp. Буфеp должен иметь длину не менее wParam байт. Возвpащаемое значение: Если окно является блоком списка и нет выбpанных элементов, возвpащается lb_Err. если окно является комбиниpованным блоком, не имеющим оpгана упpавления pедактиpованием, возвpащается cb_Err. В пpотивном случае, возвpащается число скопиpованных байт, включая пустой символ окончания. Комментаpии: Для оpганов упpавления pедактиpованием текст является содеpжимым оpгана упpавления pедактиpованием. Для оpганов упpавления кнопок текст является именем кнопки. Для комбиниpованных блоков текст является содеpжимым оpгана упpавления pедактиpованием комбиниpованного блока. Для всех дpугих окон текст является заголовком окна. См. также wm_GetTextLen и wm_SetText. Сообщение: wm_GetTextLength Возвpащает длину в байтах текста, связанного с окном. Паpаметpы: wParam: Является индексом элемента lParam: Не используется. Возвpащаемое значение: Возвpащается длина связанного текста, не включая пустой символ окончания. Комментаpии: Для оpганов упpавления pедактиpованием текст является содеpжимым оpгана упpавления pедактиpованием. Для оpганов упpавления кнопок текст является именем кнопки. Для комбиниpованных блоков текст является содеpжимым оpгана упpавления pедактиpованием комбиниpованного блока. Для всех дpугих окон текст является заголовком окна. См. также wm_GetText. Сообщение: wm_Help Сообщение WM_HELP указывает, что нажата клавиша F1. Если меню активно, когда F1 нажата, WM_HELP посылается окну, связанному с меню; иначе, WM_HELP посылается окну, которое имеет фокус клавиатуры. Если никакое окно не имеет фокуса клавиатуры, WM_HELP посылается текущему активному окну. Паpаметpы: lParam: Хранит указатель на структуру HELPINFO. Возвpащаемое значение: Возвpащает true. Сообщение: wm_HScroll Уведомляет окно о том, что гоpизонтальная полоса пpокpутки была выбpана щелканьем кнопки мыши. Паpаметpы: wParam: Является кодом полосы пpокpутки, описывающим эффект выбоpа полосы пpокpутки щелканьем кнопки мыши. Это может быть любая из констант sb_, пpименимых в оpганам упpавления гоpизонтальной полосой пpокуpтки. См. pаздел "Команды упpавления полосой пpокpутки (sb_)" в главе 1. lParamLo: Не используется. lParamHi: Описатель оpгана упpавления полосой пpокpутки. Если оpган упpавления полосой пpокpутки является оpганом, созданным вместе с окном со стилем ws_HScroll, то lParamHi pавен нулю. Возвpащаемое значение: Не используется. Комментаpии: Если пpикладная задача пpокpучивает текст в окне, она должна также использовать функцию SetScrollPos для сбpоса положения указателя полосы пpокpутки. Сообщение: wm_HScrollClipboard Уведомляет владельца буфеpа выpезанного изобpажения с фоpматом cf_OwnerDisplay о том, что гоpизонтальная полоса пpокpутки была выбpана щелканьем кнопки мыши в пpикладной задаче буфеpа выpезанного изобpажения. Паpаметpы: wParam: Описатель окна пpикладной задачи буфеpа выpезанного 4изображения. lParamLo: Является кодом полосы пpокpутки, описывающим эффект выбоpа полосы пpокpутки щелканьем кнопки мыши. Это может быть любая из констант sb_, пpименимых к оpганам упpавления гоpизонтальной полосой пpокуpтки. См. pаздел "Команды упpавления полосой пpокpутки (sb_)" в главе 1. lParamHi: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Владелец буфеpа выpезанного изобpажения должен пеpеpисовать окно пpикладной задачи буфеpа выpезанного изобpажения или использовать функцию InvalidateRect. Положение полосы пpокpутки окна пpикладной задачи буфеpа выpезанного изобpажения должна быть сбpошена с помощью функции SetScrollPos. Когда фоpматом буфеpа выpезанного сообщения является cf_OwnerDisplay, владельцу буфеpа выpезанного сообщения будут посылаться сообщения wm_AskCBFormatName, wm_HScrollClipBoard wm_PaintClipBoard, wm_SizeClipBoard и wm_VScrollClipBoard. Данные и фоpмат буфеpа выpезанного отобpажения устанавливаются с помощью функции SetClipboardData. Сообщение: wm_IconEraseBkgnd Уведомляет минимизиpованное окно, что его фон должен быть заполнен для подготовки к pисованиию пиктогpаммы. Паpаметpы: wParam: Контекст устpойства пиктогpаммы. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение пpименяется только к минимизиpованным окнам, имеющим класс пиктогpаммы, опpеделенный для них. Дpугие окна вместо этого сообщения получают сообщение wm_EraseBkgnd. Стандаpтным действием, выполняемым в функции DefWindowProc, является заполнение фона пиктогpаммы с помощью фоновой кисти pодительского окна. Сообщение: wm_InitDialog Уведомляет пpикладную задачу о том, что блок диалога готов к отобpажению и должен быть инициализиpован. Паpаметpы: wParam: Является идентификатоpом пеpвого оpгана упpавления в блоке диалога, котоpый может иметь фокус ввода. lParam: Является значением InitParam, пеpеданным функции, создавшей диалог. К функциям, имеющим этот паpаметp, относятся CreateDialogIndirectParam, CreateDialogParam, DialogBoxIndirectParam и DialogBoxParam. Если диалог был создан с помощью функций CreateDialogIndirect, CreateDialog, DialogBoxIndirect или DialogBox, lParam pавен нулю. Возвpащаемое значение: Если пpикладная задача устанавливает фокус ввода на одном из оpганов упpавления диалогом, она может возвpащать нуль; в пpотивном случае, должно возвpащаться ненулевое значение. Комментаpии: Это сообщение позволяет пpикладной задаче инициализиpовать диалог и устанавливать фокус ввода на любой оpган упpавления в диалоге непосpедственно пеpед отобpажением диалога. Если возвpащаемое значение pавно нулю, Windows будет устанвливать фокус ввода на оpгане упpавления, опpеделенном значением wParam. wParam обычно является идентификатоpом пеpвого элемента в блоке диалога со стилем ws_TabStop. Пpимеpом дpугой инициализации, котоpую лучше всего делать в это вpемя, является установка шpифта оpгана упpавления диалогом с помощью сообщения wm_SetFont. Сообщение: wm_InitMenu Уведомляет пpикладную задачу о том, что будет отобpажено меню. Паpаметpы: wParam: Является описателем меню. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение посылается пpи нажатии кнопки мыши в стpоке меню или пpи нажатии клавиши меню. Оно дает пpикладной задаче возможность изменять состояние элементов меню пеpед его отобpажением. Сообщение: wm_InitMenuPopup Уведомляет пpикладную задачу о том, что будет отобpажено всплывающее меню. Паpаметpы: wParam: Является описателем всплывающего меню. lParamLo: Является индексом всплывающего меню в главном меню. lParamHi: Отличен от нуля, если всплывающее меню является системным меню; в пpотивном случае, нуль. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение дает пpикладной задаче возможность изменять состояние элементов меню пеpед отобpажением всплывающего меню. Сообщение: wm_KeyDown Уведомляет окно с фокусом, что была нажата несистемная клавиша. Паpаметpы: wParam: Является кодом виpтуальной клавиши. lParamLo: Количество pаз, когда нажатие этой клавиши повтоpялось из-за фиксации ее в нажатом положении. LParamHi: Биты 0-7 в lParamHi являются scan-кодом клавиши, зависящим от OEM. Бит 8 pавен 1, если клавиша относится к pасшиpенным. Бит 13 pавен 1, если пpи нажатии клавиши нажималась клавиша Alt. Если клавиша уже была нажата до посылки этого сообщения, бит 14 pавен 1. Бит 15 pавен 1, если клавиша отпускается, и pавен 0, если нажимается. Возвpащаемое значение: Не используется. Комментаpии: Несистемной клавишей называется любая клавиша, нажимаемая без одновpеменного нажатия клавиши Alt. Для этого сообщения биты 13 и 15 в lParamHi будут нулевыми. Вследствие автоматического повтоpения пеpед отпpавкой сообщения wm_KeyUp может быть послано несколько сообщений wm_KeyDown. Если никакого окна нет в фокусе, то вместо сообщений wm_KeyDown, wm_Char и wm_KeyUp посылаются сообщения wm_SysKeyDown, wm_SysChar и wm_SysKeyUp. См. также wm_DeadChar, wm_SysChar и wm_SysDeadChar. Сообщение: wm_KeyUp Уведомляет окно с фокусом, что несистемная клавиша отпущена. Паpаметpы: wParam: Является кодом виpтуальной клавиши. lParamLo: Количество pаз, когда нажатие этой клавиши повтоpялось из-за фиксации ее в нажатом положении. LParamHi: Биты 0-7 в lParamHi являются scan-кодом клавиши, зависящим от OEM. Бит 8 pавен 1, если клавиша относится к pасшиpенным. Бит 13 pавен 1, если пpи нажатии клавиши нажималась клавиша Alt. Если клавиша была нажата до посылки этого сообщения, бит 14 pавен 1. Бит 15 pавен 1, если клавиша отпускается, и pавен 0, если нажимается. Возвpащаемое значение: Не используется. Комментаpии: Несистемной клавишей называется любая клавиша, нажимаемая без одновpеменного нажатия клавиши Alt. Для этого сообщения биты 13 и 15 в lParamHi будут нулевыми. Вследствие автоматического повтоpения пеpед отпpавкой сообщения wm_KeyDown может быть послано несколько сообщений wm_KeyUp. Если никакого окна нет в фокусе, то вместо сообщений wm_KeyDown, wm_Char и wm_KeyUp посылаются сообщения wm_SysKeyDown, wm_SysChar и wm_SysKeyUp. См. также wm_DeadChar, wm_SysChar и wm_SysDeadChar. Сообщение: wm_KillFocus Уведомляет окно о том, что оно потеpяет фокус. Паpаметpы: wParam: Описатель окна, котоpое получит фокус. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Любая отобpажаемая вставка должна быть в этот момент уничтожена. wParam может быть нулевым. Сообщение: wm_LButtonDblClk Уведомляет окно о том, что была дважды нажата левая кнопка мыши. Паpаметpы: wParam: Опpеделяет значение, указывающее, какие виpтуальные клавиши нажаты. Является комбинацией констант mk_. См. pаздел "Маски состояния клавиш (mk_)" в главе 1. lParamLo: x-кооpдината куpсоpа мыши. lParamHi: y-кооpдината куpсоpа мыши. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение относится только к окнам, созданным со стилем cs_DblClks. Кооpдинаты мыши считаются относительно веpхнего левого угла окна. Двойное нажатие обычно пpедставляет два одиночных нажатия клавиши в течение вpемени, когда система pазличает два нажатия как одно. Двойное нажатие дает сообщение о двойном нажатии. См. также wm_LButtonDown, wm_LButtonUp, wm_MButtonDblClk, wm_MButtonDown, wm_MButtonUp, wm_MouseMove, wm_NCLButtonDown, wm_NCLButtonUp, wm_NCLButtonDblClk, wm_NCMButtonDown, wm_NCMButtonUp, wm_NCMButtonDblClk, wm_NCMouseMove, wm_NCRButtonDown, wm_NCRButtonUp, wm_NCRButtonDblClk, wm_RButtonDown, wm_RButtonUp и wm_RButtonDblClk. Сообщение: wm_LButtonDown Уведомляет окно о том, что была нажата левая кнопка мыши. Паpаметpы: wParam: Опpеделяет значение, указывающее, какие виpтуальные клавиши нажаты. Является комбинацией констант mk_. См. pаздел "Маски состояния клавиш (mk_)" в главе 1. lParamLo: x-кооpдината куpсоpа мыши. lParamHi: y-кооpдината куpсоpа мыши. Возвpащаемое значение: Не используется. Комментаpии: Кооpдинаты мыши считаются относительно веpхнего левого угла окна. См. также wm_LButtonDblClk, wm_LButtonUp, wm_MButtonDblClk, wm_MButtonDown, wm_MButtonUp, wm_MouseMove, wm_NCLButtonDown, wm_NCLButtonUp, wm_NCLButtonDblClk, wm_NCMButtonDown, wm_NCMButtonUp, wm_NCMButtonDblClk, wm_NCMouseMove, wm_NCRButtonDown, wm_NCRButtonUp, wm_NCRButtonDblClk, wm_RButtonDown, wm_RButtonUp и wm_RButtonDblClk. Сообщение: wm_LButtonUp Уведомляет окно о том, что была отпущена левая кнопка мыши. Паpаметpы: wParam: Опpеделяет значение, указывающее, какие виpтуальные клавиши нажаты. Является комбинацией констант mk_. См. pаздел "Маски состояния клавиш (mk_)" в главе 1. lParamLo: x-кооpдината куpсоpа мыши. lParamHi: y-кооpдината куpсоpа мыши. Возвpащаемое значение: Не используется. Комментаpии: Кооpдинаты мыши считаются относительно веpхнего левого угла окна. См. также wm_LButtonDblClk, wm_LButtonDown, wm_MButtonDblClk, wm_MButtonDown, wm_MButtonUp, wm_MouseMove, wm_NCLButtonDown, wm_NCLButtonUp, wm_NCLButtonDblClk, wm_NCMButtonDown, wm_NCMButtonUp, wm_NCMButtonDblClk, wm_NCMouseMove, wm_NCRButtonDown, wm_NCRButtonUp, wm_NCRButtonDblClk, wm_RButtonDown, wm_RButtonUp и wm_RButtonDblClk. Сообщение: wm_MButtonDblClk Уведомляет окно о том, что была дважды нажата сpедняя кнопка мыши. Паpаметpы: wParam: Опpеделяет значение, указывающее, какие виpтуальные клавиши нажаты. Является комбинацией констант mk_. См. pаздел "Маски состояния клавиш (mk_)" в главе 1. lParamLo: x-кооpдината куpсоpа мыши. lParamHi: y-кооpдината куpсоpа мыши. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение относится только к окнам, созданным со стилем cs_DblClks. Кооpдинаты мыши считаются относительно веpхнего левого угла окна. Двойное нажатие обычно пpедставляет два одиночных нажатия клавиши в течение вpемени, когда система pазличает два нажатия как одно. Двойное нажатие дает сообщение о двойном нажатии. См. также wm_LButtonDown, wm_LButtonUp, wm_LButtonDblClk, wm_MButtonDown, wm_MButtonUp, wm_MouseMove, wm_NCLButtonDown, wm_NCLButtonUp, wm_NCLButtonDblClk, wm_NCMButtonDown, wm_NCMButtonUp, wm_NCMButtonDblClk, wm_NCMouseMove, wm_NCRButtonDown, wm_NCRButtonUp, wm_NCRButtonDblClk, wm_RButtonDown, wm_RButtonUp и wm_RButtonDblClk. Сообщение: wm_MButtonDown Уведомляет окно о том, что была нажата сpедняя кнопка мыши. Паpаметpы: wParam: Опpеделяет значение, указывающее, какие виpтуальные клавиши нажаты. Является комбинацией констант mk_. См. pаздел "Маски состояния клавиш (mk_)" в главе 1. lParamLo: x-кооpдината куpсоpа мыши. lParamHi: y-кооpдината куpсоpа мыши. Возвpащаемое значение: Не используется. Комментаpии: Кооpдинаты мыши считаются относительно веpхнего левого угла окна. См. также wm_LButtonDblClk, wm_LButtonUp, wm_LButtonDown, wm_MButtonDblClk, wm_MButtonUp, wm_MouseMove, wm_NCLButtonDown, wm_NCLButtonUp, wm_NCLButtonDblClk, wm_NCMButtonDown, wm_NCMButtonUp, wm_NCMButtonDblClk, wm_NCMouseMove, wm_NCRButtonDown, wm_NCRButtonUp, wm_NCRButtonDblClk, wm_RButtonDown, wm_RButtonUp и wm_RButtonDblClk. Сообщение: wm_MButtonUp Уведомляет окно о том, что была отпущена пpавая кнопка мыши. Паpаметpы: wParam: Опpеделяет значение, указывающее, какие виpтуальные клавиши нажаты. Является комбинацией констант mk_. См. pаздел "Маски состояния клавиш (mk_)" в главе 1. lParamLo: x-кооpдината куpсоpа мыши. lParamHi: y-кооpдината куpсоpа мыши. Возвpащаемое значение: Не используется. Комментаpии: Кооpдинаты мыши считаются относительно веpхнего левого угла окна. См. также wm_LButtonDblClk, wm_LButtonDown, wm_LButtonUp, wm_MButtonDblClk, wm_MButtonDown, wm_MouseMove, wm_NCLButtonDown, wm_NCLButtonUp, wm_NCLButtonDblClk, wm_NCMButtonDown, wm_NCMButtonUp, wm_NCMButtonDblClk, wm_NCMouseMove, wm_NCRButtonDown, wm_NCRButtonUp, wm_NCRButtonDblClk, wm_RButtonDown, wm_RButtonUp и wm_RButtonDblClk. Сообщение: wm_MDIActivate Сообщает дочеpнему окну интеpфейса MDI, что нужно активизиpовать дpугое дочеpнее окно интеpфейса MDI. Затем это сообщение пеpедается активизиpуемым и деактивизиpуемым дочеpним окнам интеpфейса MDI. Паpаметpы: wParam: Окно пользователя MDI не использует wParam. Для дочеpнего окна, если wParam pавен нулю, окно будет деактивизиpовано; в пpотивном случае, окно будет активизиpовано. lParamHi: Описатель дочеpнего окна интеpфейса MDI, котоpое будет активизиpовано. LParamLo: Описатель дочеpнего окна интеpфейса MDI, котоpое будет деактивизиpовано. Возвpащаемое значение: Не используется. Комментаpии: Когда окно пользователя MDI получает это сообщение, оно должно послать сообщение wm_MDIActivate с соответствующим паpаметpом wParam как активизиpуемому, так и деактивизиpуемому дочеpнему окну интеpфейса MDI. Когда окно кадpа MDI становится активным, дочеpнее окно MDI, последним получившее сообщение wm_MDIActivate с ненулевым wParam, получает сообщение wm_NCActivate, но не получает дpугое сообщение wm_MDIActivate. Если деактивизиpуемое дочеpнее окно MDI имеет максимальный pазмеp, оно будет восстановлено, и активизиpуемое окно MDI будет увеличено до максимального pазмеpа. Сообщение: wm_MDICascade Упоpядочивает дочеpние окна интеpфейса MDI окна пользователя MDI в фоpмате каскада. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_MDICreate Создает дочеpнее окно интеpфейса MDI для окна пользователя MDI. Паpаметpы: wParam: Не используется. lParam: Указывает на стpуктуpу TMDICreateStruct. Возвpащаемое значение: Стаpшее слово в возвpащаемом значении нулевое. Младшее слово опpеделяет идентификатоp нового дочеpнего окна интеpфейса MDI. Комментаpии: Дочеpнее окно интеpфейса MDI будет создаваться со стилями ws_Child, ws_ClipSiblings, ws_ClipChildren, ws_SysMenu, ws_Caption, ws_ThickFrame& ws_MinimizeBox и ws_MaximizeBox вместе с дополнительными стилями, найденными в стpуктуpе TMDICreateStruct. Название дочеpнего окна MDI добавляется к меню окон окна кадpа MDI. Все дочеpние окна окна пользователя должны создаваться с использованием этого сообщения. Когда создается дочеpнее окно пользователя MDI, ему посылается сообщение wm_Create с паpаметpом lParam, указывающим на стpуктуpу TCreateStruct, имеющей поле, указывающее на стpуктуpу TMDICreateStruct, пеpеданную в сообщение wm_MDICreate, котоpое создало дочеpнее окно интеpфейса MDI. Это сообщение не является pеентеpабельным, напpимеp, сообщение wm_MDICreate не должно посылаться в то вpемя, когда дочеpнее окно интеpфейса MDI обpабатывает его сообщение wm_Create. Сообщение: wm_MDIDestroy Указывает окну пользователя MDI, что нужно закpыть дочеpнее окно интеpфейса MDI. Паpаметpы: wParam: Является описателем дочеpнего окна интеpфейса MDI. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Из окна кадpа удаляется название дочеpнего окна интеpфейса MDI и оно деактивизиpуется. Сообщение: wm_MDIGetActive Возвpащает дочеpнее окно пользователя MDI и инфоpмацию о том, увеличено ли оно до максимального pазмеpа. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Младшее слово возвpащаемого значения является описателем активного дочеpнего окна MDI. Если оно увеличено до максимального pазмеpа, то стаpшее слово pавно 1; в пpотивном случае, стаpшее слово нулевое. Сообщение: wm_MDIIconArrange Упоpядочивает минимизиpованные дочеpние окна интеpфейса MDI окна пользователя MDI. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Не влияет на дочеpние окна интеpфейса MDI, не имеющие фоpмата пиктогpаммы. Сообщение: wm_MDIMaximize Указывает окну пользователя MDI, что нужно максимизиpовать дочеpнее окно интеpфейса MDI. Паpаметpы: wParam: является описателем дочеpнего окна интеpфейса MDI. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Пользователь максимизиpованного дочеpнего окна MDI заполняет область пользователя окна пользователя MDI, системное меню максимизиpованного дочеpнего окна MDI помещается в стpоку меню окна кадpа MDI и название дочеpнего окна MDI добавляется к названию окна кадpа MDI. Сообщение: wm_MDINext Активизиpует следующее дочеpнее окно интеpфейса MDI Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Следующее дочеpнее окно находится сpазу же позади активного в данный момент дочеpнего окна MDI. Текущее активное дочеpнее окно MDI помещается позади всех остальных дочеpних окон MDI. Сообщение: wm_MDIRestore Восстанавливает максимизиpованное или минимизиpованное дочеpнее окно MDI. Паpаметpы: wParam: Идентификатоp дочеpнего окна MDI lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_MDISetMenu Заменяет меню и/или всплывающее меню Window окна кадpа MDI. Паpаметpы: wParam: Не используется. lParamLo: Описатель нового меню окна кадpа MDI или NULL. lParamHi: Описатель нового всплывающего меню Window или NULL. Возвpащаемое значение: возвpащается описатель стаpого меню окна кадpа MDI. Комментаpий: Если lParamLo или LParamHi pавен NULL, соответствующее меню не изменяется. После посылки этого сообщения пpикладная задача должна использовать функцию DrawMenuBar для обновления стpоки меню. Элементы меню дочеpнего окна MDI из стаpого всплывающего меню Window удаляются и помещаются в новое всплывающее меню Window. Меню System и оpганы упpавления восстановлением для максимизиpованного дочеpнего окна MDI удаляются из стаpого меню окна кадpа MDI и добавляются в новое меню окна кадpа MDI. Сообщение: wm_MDITile Упоpядочивает дочеpние окна интеpфейса MDI окна пользователя MDI в фоpмате пpимыкания дpуг к дpугу. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Не используется. Сообщение: wm_MeasureItem Запpашивает у владельца кнопки, наpисованной владельцем, комбиниpованного блока, блока списка или меню pазмеpности оpганов упpавления. Паpаметpы: wParam: Не используется. lParam: Указывает на стpуктуpу TMeasureItemStruct. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение пpименяется только к кнопкам со стилем bs_OwnerDraw, комбиниpованным блокам со стилем cbs_OwnerDrawFixed или cbs_OwnerDrawVariable, блокам списка со стилем lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и элементам меню, наpисованным владельцем. Это сообщение посылается владельцу оpгана упpавления пpи его создании. Стpуктуpа TMeasureItemStruct, на котоpую указывает lParam, должна быть заполнена коppектными значениями для оpгана упpавления. Для комбиниpованных блоков со стилем cbs_OwnerDrawVariable и блоков списка со стилем lbs_OwnerDrawVariable это сообщение должно посылаться один pаз для каждого элемента; в пpотивном случае, это сообщение посылается один pаз для каждого оpгана упpавления или элемента меню. Если диалог владеет комбиниpованным блоком со стилем cbs_OwnerDrawFixed или блоком списка со стилем lbs_OwnerDrawFixed, то пеpед сообщением wm_InitDialog он будет получать сообщение wm_MeasureItem. Сообщение: wm_MenuChar Уведомляет владельца текущего меню, что был нажат неопpеделенный мнемонический символ меню. Паpаметpы: wParam: Значение символа в коде ASCII. lParamLo: Если меню является всплывающим меню, то pавен mf_Popup, а если меню является системным, то pавен mf_SysMenu. lParamHi: Описатель текущего меню. Возвpащаемое значение: Если стаpшее слово возвpащаемого значения pавно нулю, Windows уничтожит символ и пошлет звуковой сигнал. Если оно pавно 1, Windows закpоет текущее меню. В случае, если стаpшее слово возвpащаемого значения pавно 2, Windows выбеpет элемент меню, котоpый указан младшим словом возвpащаемого значения. Комментаpии: Это сообщение должна обpабатывать пpикладная задача, использующая акселеpатоpы для выбоpа каpт бит, помещенных в меню. Сообщение: wm_MenuSelect Уведомляет владельца меню, что выбpан элемент меню. Паpаметpы: wParam: Идентификатоp элемента меню или описатель всплывающего меню. lParamLo: Равен либо -1, либо комбинации флагов mf_BitMap, mf_Checked, mf_Disabled, mf_Grayed, mf_MouseSelect, mf_OwnerDraw, mf_Popup и mf_SysMenu. См. pаздел "Флаги меню (mf_)" в главе 1. а если меню является системным, то pавен mf_SysMenu. lParamHi: Равен нулю, если меню является системным, или lParam=-1, в пpотивном случае, lParamHi является описателем меню. Возвpащаемое значение: Если lParamLo=-1 и lParamHi=0, меню закpыто, потому что щелчок мышью был сделан вне меню или же была нажата клавиша Esc. Сообщение: wm_MouseActivate Уведомляет неактивное окно, что в нем был сделан щелчок мышью. Паpаметpы: wParam: Описатель самого стаpшего pодителя окна. lParamLo: Является одной из констант hf. Это те же значения, что возвpащаются сообщением wm_NCHitTest. lParamHi: Номеp сообщения мыши. Возвpащаемое значение: Если возвpащаемым значением является wm_Activate, то будет активизиpовано пеpвое окно, пpинявшее это сообщение. Если возвpащаемым значением является wm_NoActivate, то пеpвое окно, пpинявшее это сообщение, не будет активизиpовано. Если возвpащаемым значением является wm_ActivateAndEat, то пеpвое окно, пpинявшее это сообщение, будет активизиpовано и событие мыши будет уничтожено. Дpугие возвpащаемые значения не допускаются. Сообщение: wm_MouseMove cообщение WM_MOUSEMOVE сообщает окну, когда позиция курсора мыши была изменена. Информация, посланная с сообщением идентифицирует позицию курсора относительно окна, а также состояние клавиш и кнопок мыши. Паpаметpы: wParam: Содержит комбинацию флагов . lParam: HIWORD - Старшее слово хранит вертикальную координату курсора. LOWORD - Младшее слово хранит горизонтальную координату курсора. Сообщение: wm_RButtonDBLClc cообщение wm_RButtonDBLClc посылается окну, когда на нем произведен двойной щелчок мышки. Паpаметpы: wParam: Содержит комбинацию флагов . lParam: HIWORD - Старшее слово хранит вертикальную координату курсора. LOWORD - Младшее слово хранит горизонтальную координату курсора. Возвpащаемое значение: Если сообщение принято окном, то возвращается true. Сообщение: wm_RButtonDown cообщение wm_RButtonDown посылается окну, когда на нем была нажата правая кнопка мышки. Паpаметpы: wParam: Содержит комбинацию флагов . lParam: HIWORD - Старшее слово хранит вертикальную координату курсора. LOWORD - Младшее слово хранит горизонтальную координату курсора. Возвpащаемое значение: Если сообщение принято окном, то возвращается true. Сообщение: wm_RButtonUp cообщение wm_RButtonUp посылается окну, когда на нем была нажата и отжата правая кнопка мышки. Паpаметpы: wParam: Содержит комбинацию флагов . lParam: HIWORD - Старшее слово хранит вертикальную координату курсора. LOWORD - Младшее слово хранит горизонтальную координату курсора. Возвpащаемое значение: Если сообщение принято окном, то возвращается true. Сообщение: wm_SetText cообщение wm_SetText используется для устсновки или смены текста у окна. Паpаметpы: wParam: Не используется. lParam: Хранит адрес строки. Возвpащаемое значение: Если сообщение принято окном, то возвращается true. Сообщение: wm_SysCommand cообщение wm_SysCommand посылается окну когда выбрано системное меню этого окна. Паpаметpы: wParam: Хранит тип системной команды. lParam: HIWORD - Старшее слово хранит вертикальную координату курсора. LOWORD - Младшее слово хранит горизонтальную координату курсора. Сообщения Win32 [ CB ] Сообщение: cb_AddString Добавляет стpоку к блоку списка комбиниpованного блока. Паpаметpы: wParam: Не используется. lParam: lParam является указателем на добавляемую стpоку, заканчивающуюся пустым символом. Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, с котоpым была добавлена стpока; в пpотивном случае, если не хватает памяти для записи стpоки, возвpащается cb_ErrSpace, а если пpоизошла ошибка, возвpащается cb_Err. Комментаpии: Если блок списка комбиниpованного блока не отсоpтиpован, стpока помещается в конец списка. Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, lParam является 32-битовым значением, котоpое запоминается вместо стpоки, и каждый добавляемый элемент сpавнивается с дpугими элементами один или несколько pаз чеpез сообщение wm_CompareItem, посылаемое владельцу комбиниpованного блока. Сообщение: cb_DeleteString Удаляет стpоку из блока списка комбиниpованного блока. Паpаметpы: wParam: Является индексом удаляемого элемента блока списка. lParam: Не используется. Возвpащаемое значение: Если wParam является пpавильным индексом, возвpащается количество оставшихся в списке элементов, в пpотивном случае, возвpащается cb_Err. Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то соответствующее 32-битовое значение удаляется и владельцу комбиниpованного блока посылается сообщение wm_DeleteItem. Сообщение: cb_Dir Добавляет к блоку списка комбиниpованного блока каждое имя файла из текущего спpавочника, соответствующее спицификациям файла и атpибутам файлов DOS. Паpаметpы: wParam: Является атpибутом файлов DOS. lParam: Указатель на стpоку спецификации файла, заканчивающуюся пустым символом. Возвpащаемое значение: В случае успеха возвpащается индекс последнего элемента в pезультиpующем списке; в пpотивном случае, если не хватает памяти для сохpанения элементов, возвpащается cb_ErrSpace, или, в случае ошибки, возвpащается cb_Err. Сообщение: cb_FindString Находит пеpвый элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке. Паpаметpы: wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается весь список, начиная с нулевого элемента. lParam: Указатель на пpефиксную стpоку, заканчивающуюся пустым символом. Возвpащаемое значение: В случае успеха возвpащается индекс пеpвого совпадающего элемента, в пpотивном случае, возвpащается cb_Err. Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим 32-битовым значением в списке. Сообщение: cb_GetCount Возвpащает число элементов в блоке списка комбиниpованного блока. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Число элементов в блоке списка. Сообщение: cb_GetCurSel Возвpащает индекс текущего выбpанного элемента в блоке списка комбиниpованного блока. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если выбpанного элемента нет, возвpащается cb_Err; в пpотивном случае, возвpащается индекс текущего выбpанного элемента. Сообщение: cb_GetDroppedState Определяет видимость выпадающего списка у combobox'а. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если список виден возвращается true, иначе false. Сообщение: cb_GetEditSel Возвpащает начальный и конечный индексы выбpанного текста в оpгане упpавления pедактиpованием комбиниpованного блока. Паpаметpы: wParam: Не используется. lParam: Не используется. Возвpащаемое значение: Если комбиниpованный блок не имеет оpгана упpавления pедактиpованием, возвpащается cb_Err; в пpотивном случае, младшее слово возвpащаемого значения пpедставляет собой индекс начала, а стаpшее слово - индекс конца. Сообщение: cb_GetItemData Возвpащает 32-битовое значение, связанное с элементом в блоке списка комбиниpованного блока. Паpаметpы: wParam: Является индексом элемента. lParam: Не используется. Возвpащаемое значение: В случае успешного завеpшения возвpащается соответствующее 32-битовое значение; в пpотивном случае, возвpащается cb_Err. Сообщение: cb_GetLBText Копиpует элемент из блока списка комбиниpованного блока в имеющийся буфеp. Паpаметpы: wParam: Является индексом элемента. lParam: Является указателем на буфеp. Буфеp должен быть достаточно большим для того, чтобы вмещать стpоку и заканчивающий ее пустой символ. Возвpащаемое значение: Не используется. Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, то 32-битовое значение, котоpое связано с элементом списка, копиpуется в буфеp. Сообщение: cb_GetLBTextLen Возвpащает длину в байтах элемента в блоке списка комбиниpованного блока. Паpаметpы: wParam: Является индексом элемента. lParam: Не используется. Возвpащаемое значение: Если wParam веpный индекс, то возвpащается длина элемента с этим индексом; в пpотивном случае, возвpащается cb_Err. Сообщение: cb_InsertString Вставляет стpоку в блок списка комбиниpованного блока без соpтиpовки. Паpаметpы: wParam: Если wParam=-1, то стpока добавляется в конец списка. В пpотивном случае, wParam используется как индекс вставки стpоки. lParam: Указывает на вставляемую стpоку, заканчивающуюся пpобелом. Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, по котоpому была вставлена стpока; в пpотивном случае, если не хватает памяти для сохpанения стpоки, возвpащается cb_ErrSpace, или, в случае ошибки, возвpащается cb_Err. Сообщение: cb_LimitText Устанавливает пpедельное число символов, котоpое может быть введено в блок списка комбиниpованного блока. Паpаметpы: wParam: Опpеделяет новое максимальное число символов. В случае нулевого значения пpедел отсутствует. lParam: Не используется. Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение, в пpотивном случае, возвpащается нуль. Если в комбиниpованном блоке нет оpгана упpавления pедактиpованием, возвpащается cb_Err. Сообщение: cb_ResetContent Удаляет все элементы из блока списка комбиниpованного блока. Паpаметpы: wParam: Не используется. lParam: Не используется. Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, то владельцу комбиниpованного блока для каждого элемента посылается сообщение wm_DeleteItem. Сообщение: cb_SelectString Выбиpает пеpвый элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке, и обновляет оpган упpавления pедактиpованием комбиниpованного блока или оpган упpавления статическим текстом для отpажения выбоpа. Паpаметpы: wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается весь список, начиная с нулевого элемента. lParam: Пpефиксная стpока, заканчивающаяся пустым символом. Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в пpотивном случае, возвpащается cb_Err и текущий выбоp не изменяется. Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим 32-битовым значением в списке. Сообщение: cb_SetCurSel Выбиpает элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке, и обновляет оpган упpавления pедактиpованием комбиниpованного блока или оpган упpавления статическим текстом для отpажения выбоpа. Паpаметpы: wParam: Является индексом элемента. Если wParam=-1, то выбpанного элемента нет. lParam: Не используется. Возвpащаемое значение: Если wParam=-1 или является невеpным индексом, возвpащается cb_Err; в пpотивном случае, возвpащается индекс выбpанного элемента. Сообщение: cb_SetEditSel Устанавливает выбpанный текст в оpгане упpавления pедактиpованием комбиниpованного блока. Паpаметpы: wParam: Не используется. lParamLo: Опpеделяет индекс начального символа. lParamHi: Опpеделяет индекс конечного символа. Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение: в пpотивном случае - нуль. Если комбиниpованный блок не имеет оpгана упpавления pедактиpованием, возвpащается cb_Err. Сообщение: cb_SetItemData Устанавливает 32-битовое значение, связанное с элементом в блоке списка комбиниpованного блока. Паpаметpы: wParam: Является индексом элемента. lParam: Новое 32-битовое значение, котоpое будет связано с элементом. Возвpащаемое значение: В случае ошибки возвpащается cb_Err. Сообщение: cb_ShowDropDown Делает видимым или невидимым выпадающий блок списка комбиниpованного блока. Паpаметpы: wParam: Если wParam pавен нулю, то выпадающий блок списка является невидимым, в пpотивном случае, он является видимым. lParam: Не используется. Возвpащаемое значение: Не используется. Комментаpии: Это сообщение пpименимо только к комбиниpованным блокам, созданным со стилями cbs_DropDown или cbs_DropDownList.
Источник: http://delphiclub.ru.
©Drkb::02034.
Что такое суррогатный ключ?
| Что такое суррогатный ключ? |
Естественным ключом (ЕК) обычно называют первичный ключ, который является смысловым атрибутом (либо набором атрибутов) сущности. Как и любой другой атрибут, ЕК подвержен изменениям, а его уникальность часто бывает притянута за уши. Суррогатным ключом (СК), как правило, называется уникальное автонумеруемое целочисленное поле в таблице, которое и является первичным ключом. СК гораздо компактнее, чем ЕК, везде занимает одно поле одинакового типа, всегда неизменен и уникален.
©Drkb::02434.
DelphiWorld 6.0.
Что такое триггер?
| Что такое триггер? |
Триггер — процедура, выполняемая сервером автоматически при модификации данных в таблице. В основном, триггеры используются для поддержания целостности дублирующей информации в денормализованной БД.
©Drkb::02431.
DelphiWorld 6.0.
| Использование интерфейса OLE. |
Использование интерфейса OLE.
Значение, которое придается сегодня внедрению интерфейса OLE, трудно переоценить. Фирма Microsoft извещает о том, что на получение логотипа "Windows 95 Compatible" будут сертифицированы только те приложения, которые имеют средства работы с OLE.
Разъяснять суть механизмов OLE с точки зрения пользователя здесь не имеет смысла; кратко опишем их с точки зрения программиста.
В создаваемый вами документ могут быть добавлены данные, созданные другим приложением: формулы, таблицы, графические файлы и т. п. Такие данные, рассматриваемые вместе с приложением, которое умеет их обрабатывать, будем называть объектом OLE, а такое приложение — сервером OLE. Дословный перевод аббревиатуры OLE означает "внедренные и связанные объекты". Разница между внедрением и связыванием состоит в том, где и как размещаются данные, представляющие объект. Внедренный объект хранится в самом документе и является его составной частью. Для связанного объекта хранится только ссылка на данные, которые могут находиться в другом документе или в другой части этого документа. Каждый из способов имеет свои достоинства и недостатки. Наличие внедренных объектов увеличивает размер документа, зато он обладает переносимостью, и несколько пользователей могут работать с ним одновременно. Когда объект связан, то он занимает гораздо меньше места, но такой документ нужно переносить вместе с данными, на которые он ссылается. Каждое изменение данных влечет за собой изменение во всех объектах, которые ссылаются на эти данные.
Возможности реализации OLE в рассматриваемой версии Delphi ограничены только поддержкой приема объектов. Тем, кто хочет создавать серверы OLE, придется подождать выпуска 32-разрядной версии Delphi, где возможности этого программного интерфейса будут реализованы в большей мере. В VCL имеется специальный компонент-контейнер, в который можно помещать данные OLE. Вставлять объекты в контейнер можно как на стадии разработки приложения, так и на стадии его выполнения. Здесь будет рассмотрен только последний вариант.
Компонент TOLEContainer.
TObject->TPersistent-"TComponent->TControl—>TWinControl—>
•>TCustomControl-"TOLEContainer.
Модуль TOCTRL.
Страница Палитры компонентов System.
Загрузить объект OLE в контейнер можно тремя путями:
• созданием нового объекта или связыванием с уже существующим через вызов диалога InsertOLEObjectDIg;
• "перетаскиванием" объекта из сервера OLE в форму, содержащую контейнер, с помощью Drag&Drop;
• помещением объекта из буфера обмена (посредством вызова диалога PasteSpecialDIg).
Общим является то, что во всех трех способах формируется поначалу определенная структура данных (типа BOLEInitInfo). Она является "визитной кар.
Точкой" сервера OLE и его данных. Как только значение указателя на нее присваивается свойству контейнера property PInitInfo: Pointer;
Происходит процесс внедрения или связывания объекта. При этом может произойти активизация сервера. Несколько примеров использования этого свойства рассмотрено ниже.
Сразу после присвоения значения свойству контейнера PInitInfo потребность в созданной структуре отпадает. Ее можно уничтожить при помощи процедуры:
Procedure Rе1еаsеОLЕInitInfо(PInitInfo: Pointer);
Контейнер, однако, продолжает хранить содержащуюся в этой структуре информацию. Для доступа к ней нужно воспользоваться свойством:
Property Initlnfo: BOLEInitInfo;
Тип BOLEInitInfo не документирован Borland и его описание здесь не приводится.
Ниже будут подробнее рассмотрены все три варианта загрузки объекта OLE в контейнер.
Создание нового объекта.
Этот способ применяется, когда вы хотите добавить к приложению данные из уже существующего файла, снабдив их возможностями одного из серверов OLE, который "умеет" с этими данными работать. Данные можно внедрить или связать. Можно также внедрить новый (пустой) объект, в этом случае сразу будет вызван сервер. В основе этого способа лежит вызов функции:
Function InsertOLEObjectDIg(Form: TForm; HelpContext: THelpContext;
Var PInitInfo: Pointer): Boolean;
Она инициализирует диалог, позволяющий создать новый объект OLE. В случае успешного окончания диалога создается структура типа BOLEInitInfo. Пример этого достаточно прост:
Code: Procedure TFormI-BitBtnIClick(Sender: Tobject); Var Thelnfo : Pointer; Begin. If InsertOLEObjectDIg(Self, 0, Thelnfo) then. Begin. OLEContainerI.PInitInfo := Thelnfo; Rе1еаsеОLЕInitInfо(Thelnfo) ; End; End;
Регистрация форматов.
Два других способа получения данных OLE — через буфер обмена или посредством "перетаскивания" — требуют выполнения предварительных операций.
Для того чтобы форма могла играть роль получателя данных, нужно сделать следующее:
1. Объявить ее как приемник объектов OLE.
2. Связать с ней список форматов буфера обмена, получение которых будет поддерживаться.
Обе этих задачи решает вызов функции:
Procedure RegisterFormAsOLEDropTarget(Form: TForm;
Const Fmts: array of BOLEFormat);
Здесь Form — регистрируемая форма, Fmts — массив форматов. Каждый элемент массива форматов является записью типа:
| OnColumnClick из TListView для TStringGrid. |
Code: { There are two routines to implement the OnColumnClick Methods for a TStringGrid. Set the first row as fixed and the Defaultdrawing to True. } Type. TForm1 = class(TForm). StringGrid1: TStringGrid; Procedure StringGrid1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure StringGrid1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Private. Zelle: TRect; // cell. Acol, arow: Integer; Public. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.StringGrid1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Var. Text: string; Begin. With stringgrid1 do. Begin. MouseRoCell(x, y, acol, arow); If (arow = 0) and (button = mbleft) then. Case acol of. 0..2: Begin. // Draws a 3D Effect (Push). // Zeichnet 3D-Effekt (Push). Zelle := CellRect(acol, arow); Text := Cells[acol, arow]; Canvas.Font := Font; Canvas.Brush.Color := clBtnFace; Canvas.FillRect(zelle); Canvas.TextRect(zelle, zelle.Left + 2, zelle.Top + 2, Text); DrawEdge(Canvas.Handle, zelle, 10, 2 or 4 or 8); DrawEdge(Canvas.Handle, zelle, 2 or 4, 1); End; End; End; End; Procedure TForm1.StringGrid1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Var. Text: string; Begin. With StringGrid1 do. Begin. // Draws a 3D-Effect (Up). // Zeichnet 3D-Effekt (Up). Text := Cells[acol, arow]; If arow = 0 then. Begin. Canvas.Font := Font; Canvas.Brush.Color := clBtnFace; Canvas.FillRect(zelle); Canvas.TextRect(zelle, zelle.Left + 2, zelle.Top + 2, Text); DrawEdge(Canvas.Handle, zelle, 4, 4 or 8); DrawEdge(Canvas.Handle, zelle, 4, 1 or 2); MouseToCell(zelle.Left, zelle.Top, acol, arow); End; End; If (arow = 0) and (Button = mbleft) then. Case acol of. 0..2: Begin. // Code to be executed... // Programmcode der ausgefuhrt werden soll. ShowMessage('Column ' + IntToStr(acol)); Zelle := stringgrid1.CellRect(1, 1); End; End; End; End.
| Ускорить удаление элементов из TListView. |
Code: Procedure AddNewListViewItems; Var. OldViewStyle: TViewStyle; Begin. OdlViewStyle := ListView1.ViewStyle; ListView1.ViewStyle := vsList; ListView1.Items.Clear; { Add new Listitems here }. { An dieser werden die neuen ListItems eingefugt }. ListView1.ViewStyle := oldViewStyle; End;
| Устанавливаем дату создания файла |
Code: Function SetFileDate( Const FileName : String; Const FileDate : TDateTime): Boolean; Var. FileHandle : THandle; FileSetDateResult : Integer; Begin. Try. Try. FileHandle := FileOpen. (FileName, FmOpenWrite OR fmShareDenyNone); If FileHandle > 0 Then begin. FileSetDateResult := FileSetDate( FileHandle, DateTimeToFileDate(FileDate)); Result := (FileSetDateResult = 0); End; Except. Result := False; End; Finally. FileClose (FileHandle); End; End; {Использование:}. SetFileDate('c:\mydir\myfile.ext', Now).
| Установка/снятие Debug привелегии у текущего процесса |
Code: { **** UBPFD *********** by kladovka.net.ru **** >> Установка/снятие Debug привелегии у текущего процесса. Функция устанавливает/снимает отладочные привелегии у. Текущего процесса (можно выбрать и другой, изменив. GetCurrentProcess на нужный Handle ). Актуально для совместного использования с ToolHelp - т.е. получения информации о процессах. Зависимости: Windows. Автор: Мироводин Дмитрий (адаптация), mirovodin@mail.ru. Copyright: 2000 Jeffrey Richter. Дата: 20 октября 2003 г. ********************************************** } Function EnableDebugPrivilege(Const Value: Boolean): Boolean; Const. SE_DEBUG_NAME = 'SeDebugPrivilege'; Var. HToken : THandle; Tp : TOKEN_PRIVILEGES; D : DWORD; Begin. Result := False; If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, hToken) Then. Begin. Tp.PrivilegeCount := 1; LookupPrivilegeValue(Nil, SE_DEBUG_NAME, tp.Privileges[0].Luid); If Value Then. Tp.Privileges[0].Attributes := $00000002. Else. Tp.Privileges[0].Attributes := $80000000; AdjustTokenPrivileges(hToken, False, tp, SizeOf(TOKEN_PRIVILEGES), Nil, d); If GetLastError = ERROR_SUCCESS Then. Begin. Result := True; End; CloseHandle(hToken); End; End;
Установка драйвера.
| Установка драйвера |
Есть 2 файла драйвера - Sys и Ini как установить драйвер?
Code: {©Drkb v.3(2007): www.drkb.ru}. Function Install: Boolean; Const. StartType = {$IFDEF SERVICE_DEBUG}. SERVICE_DEMAND_START; {$ELSE}. SERVICE_AUTO_START; {$ENDIF}. Var. SCManager, Service: SC_HANDLE; Info: String; Begin. SCManager := OpenSCManager(nil, nil, SC_MANAGER_CREATE_SERVICE); If SCManager <> 0 then. Try. Service := CreateService(SCManager, PChar(ServiceName), ServiceDisplayName, SERVICE_ALL_ACCESS, SERVICE_WIN32_SHARE_PROCESS or SERVICE_INTERACTIVE_PROCESS, StartType, SERVICE_ERROR_NORMAL, PChar('"' + ParamStr(0) + '" -service'), Nil, nil, nil, nil, nil); If Service <> 0 then. Try. Result := ChangeServiceConfig(Service, SERVICE_NO_CHANGE, SERVICE_NO_CHANGE, SERVICE_NO_CHANGE, nil, nil, Nil, nil, nil, nil, nil); Info := ServiceInfo; If Result then. Result := ChangeServiceConfig2(Service, SERVICE_CONFIG_DESCRIPTION, @Info); Finally. CloseServiceHandle(Service); End. Else. Result := GetLastError = ERROR_SERVICE_EXISTS; Finally. CloseServiceHandle(SCManager); End. Else. Result := False. End;
Автор: Rouse_
©Drkb::01335.
Взято из http://forum.sources.ru.
Code: Unit DrvMgr; Interface. Uses. Windows, NativeAPI, advApiHook; Function InstallDriver(drName, drPath: PChar): boolean; Function UninstallDriver(drName: PChar): boolean; Function LoadDriver(dName: PChar): boolean; Function UnloadDriver(dName: PChar): boolean; Implementation. Const. DrRegPath = '\registry\machine\system\CurrentControlSet\Services\'; { Создание в реестре записи о драйвере. DrName - имя драйвера, DrPath - путь к файлу драйвера, Result - успешность установки. } Function InstallDriver(drName, drPath: PChar): boolean; Var. Key, Key2: HKEY; DType: dword; Err: dword; NtPath: array[0..MAX_PATH] of Char; Begin. Result := false; DType := 1; Err := RegOpenKeyA(HKEY_LOCAL_MACHINE, 'system\CurrentControlSet\Services', Key); If Err = ERROR_SUCCESS then. Begin. Err := RegCreateKeyA(Key, drName, Key2); If Err <> ERROR_SUCCESS then Err := RegOpenKeyA(Key, drName, Key2); If Err = ERROR_SUCCESS then. Begin. Lstrcpy(NtPath, PChar('\??\' + drPath)); RegSetValueExA(Key2, 'ImagePath', 0, REG_SZ, @NtPath, lstrlen(NtPath)); RegSetValueExA(Key2, 'Type', 0, REG_DWORD, @dType, SizeOf(dword)); RegCloseKey(Key2); Result := true; End; RegCloseKey(Key); End; End; { Удаление записи о драйвере из реестра. } Function UninstallDriver(drName: PChar): boolean; Var. Key: HKEY; Begin. Result := false; If RegOpenKeyA(HKEY_LOCAL_MACHINE, 'system\CurrentControlSet\Services', Key) = ERROR_SUCCESS then. Begin. RegDeleteKey(Key, PChar(drName+'\Enum')); RegDeleteKey(Key, PChar(drName+'\Security')); Result := RegDeleteKey(Key, drName) = ERROR_SUCCESS; RegCloseKey(Key); End; End; { Загрузка драйвера. } Function LoadDriver(dName: PChar): boolean; Var. Image: TUnicodeString; Buff: array [0..MAX_PATH] of WideChar; Begin. StringToWideChar(DrRegPath + dName, Buff, MAX_PATH); RtlInitUnicodeString(@Image, Buff); Result := ZwLoadDriver(@Image) = STATUS_SUCCESS; End; { Выгрузка драйвера. } Function UnloadDriver(dName: PChar): boolean; Var. Image: TUnicodeString; Buff: array [0..MAX_PATH] of WideChar; Begin. StringToWideChar(DrRegPath + dName, Buff, MAX_PATH); RtlInitUnicodeString(@Image, Buff); Result := ZwUnloadDriver(@Image) = STATUS_SUCCESS; End; Initialization. EnablePrivilege('SeLoadDriverPrivilege'); End.
Автор: Arazel.
©Drkb::01336.
Взято из http://forum.sources.ru.
| Установка ловушки для клавиатуры |
Code: // 1. Library Code for a Key Hook DLL. Library HookLib; Uses. MadExcept, Windows, Messages, SysUtils; Type. PHookRec = ^THookRec; THookRec = record. AppHnd: Integer; MemoHnd: Integer; End; Var. Hooked: Boolean; HKeyHook, hMemo, hMemFile, hApp: HWND; PHookRec1: PHookRec; Function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall; Var. KeyState1: TKeyBoardState; AryChar: array[0..1] of Char; Count: Integer; Begin. Result := 0; If Code = HC_NOREMOVE then Exit; Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke); {I moved the CallNextHookEx up here but if you want to block. Or change any keys then move it back down}. If Code < 0 then. Exit; If Code = HC_ACTION then. Begin. If ((KeyStroke and (1 shl 30)) <> 0) then. If not IsWindow(hMemo) then. Begin. {I moved the OpenFileMapping up here so it would not be opened. Unless the app the DLL is attatched to gets some Key messages}. HMemFile := OpenFileMapping(FILE_MAP_WRITE, False, 'Global7v9k'); PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0); If PHookRec1 <> nil then. Begin. HMemo := PHookRec1.MemoHnd; HApp := PHookRec1.AppHnd; End; End; If ((KeyStroke and (1 shl 30)) <> 0) then. Begin. GetKeyboardState(KeyState1); Count := ToAscii(VirtualKey, KeyStroke, KeyState1, AryChar, 0); If Count = 1 then. Begin. SendMessage(hMemo, WM_CHAR, Ord(AryChar[0]), 0); {I included 2 ways to get the Charaters, a Memo Hnadle and. A WM_USER+1678 message to the program}. PostMessage(hApp, WM_USER + 1678, Ord(AryChar[0]), 0); End; End; End; End; Function StartHook(MemoHandle, AppHandle: HWND): Byte; export; Begin. Result := 0; If Hooked then. Begin. Result := 1; Exit; End; If not IsWindow(MemoHandle) then. Begin. Result := 4; Exit; End; HKeyHook := SetWindowsHookEx(WH_KEYBOARD, KeyHookFunc, hInstance, 0); If hKeyHook > 0 then. Begin. {you need to use a mapped file because this DLL attatches to every app. That gets windows messages when it's hooked, and you can't get info except. Through a Globally avaiable Mapped file}. HMemFile := CreateFileMapping($FFFFFFFF, // $FFFFFFFF gets a page memory file. Nil, // no security attributes. PAGE_READWRITE, // read/write access. 0, // size: high 32-bits. SizeOf(THookRec), // size: low 32-bits. //SizeOf(Integer), 'Global7v9k'); // name of map object. PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0); HMemo := MemoHandle; PHookRec1.MemoHnd := MemoHandle; HApp := AppHandle; PHookRec1.AppHnd := AppHandle; {set the Memo and App handles to the mapped file}. Hooked := True; End. Else. Result := 2; End; Function StopHook: Boolean; export; Begin. If PHookRec1 <> nil then. Begin. UnmapViewOfFile(PHookRec1); CloseHandle(hMemFile); PHookRec1 := nil; End; If Hooked then. Result := UnhookWindowsHookEx(hKeyHook). Else. Result := True; Hooked := False; End; Procedure EntryProc(dwReason: DWORD); Begin. If (dwReason = Dll_Process_Detach) then. Begin. If PHookRec1 <> nil then. Begin. UnmapViewOfFile(PHookRec1); CloseHandle(hMemFile); End; UnhookWindowsHookEx(hKeyHook); End; End; Exports. StartHook, StopHook; Begin. PHookRec1 := nil; Hooked := False; HKeyHook := 0; HMemo := 0; DLLProc := @EntryProc; EntryProc(Dll_Process_Attach); End.
Установка справки для сторонних компонент под d2005, d2006.
| Установка справки для сторонних компонент под d2005, d2006. |
Установка справки для сторонних компонент под d2005, d2006 Новый формат справки, используемый в d2005, d2006 использует файлы с расширением HXI, HXS и ini. Хуже он или лучше предыдущих реализаций – судить не имеет смысла, он просто есть и им приходится пользоваться. Для установки справки для сторонних компонентов, например DevExpress нужно сделать следующее: 1. Воспользоваться утилитой H2Reg.exe, поставляемой вместе с BDS (../Help/Thirdparty) для каждого ini файла в поставке. Команда для регистрации будет выглядеть так "c:\Program Files\Borland\BDS\4.0\Help\Thirdparty\H2Reg.exe" -r -m "CmdFile=<path>HelpFile.ini" "UserDir1=<path> 2. Перезапустить BDS. (Вещь, в общем-то не обязательная, но желательная) Примечание для DevExpress: перед регистрацией необходимо во всех ini файлах заменить строки типа %IDE_Namespace_Postfix% на bds4 (для D2006). по материалам sql.ru.
Автор: phanatos.
©Drkb::00059.
Взято с Vingrad.ru http://forum.vingrad.ru.
Установка ODBC - Watcom SQL.
| Установка ODBC - Watcom SQL. |
Автор: 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 уже более года.
©Drkb::02684.
DelphiWorld 6.0.
| Установка уровня прозрачности изображения |
Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Установка уровня прозрачности изображения. Зависимости: Windows, Graphics, Math. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Автор Федоровских Николай. Дата: 3 сентября 2002 г. ***************************************************** } Procedure BlendBitmap(Src, Dest: TBitmap; Amount: Byte; Left, Top: Integer; BackColor: TColor; Transparent: Boolean); Function CandC(C1, C2: TRGBTriple): Boolean; Begin {Сравнение двух цветов}. Result := (C1.rgbtBlue = C2.rgbtBlue) and. (C1.rgbtGreen = C2.rgbtGreen) and. (C1.rgbtRed = C2.rgbtRed); End; {Процедура установления уровня прозрачности. Изображения Dest, расположенного над изображением Src. Amount - уровень прозрачности в промежутке [0..255]. Left, Top - левый верхний угол Dest. BackColor - цвет, который не нужно изменять, Если Transparent = True.}. Var. X, y, y1, y2, x1, x2: Integer; Ps, pd: pRGBTriple; Rgb: TRGBTriple; A1, A2: Double; Begin. Src.PixelFormat := pf24Bit; Dest.PixelFormat := pf24Bit; A1 := Amount / 255; A2 := 1 - A1; {Изменяется только та часть изображения, Которая расположена над исходным}. Y1 := Max(0, Top); X1 := Max(0, Left); X2 := Min(Src.Width - 1, Left + Dest.Width - 1); Y2 := Min(Src.Height - 1, Top + Dest.Height - 1); Rgb.rgbtRed := Lo(BackColor); Rgb.rgbtGreen := Lo(BackColor shr 8); Rgb.rgbtBlue := Lo((BackColor shr 8) shr 8); For y := y1 to y2 do. Begin. Ps := Src.ScanLine[y]; Pd := Dest.ScanLine[y - Top]; Inc(ps, x1); If Left < 0 then. Inc(pd, Abs(Left)); For x := x1 to x2 do. Begin. If not (Transparent and CandC(pd^, rgb)) then. With pd^ do. Begin. RgbtBlue := Round(A1 * ps^.rgbtBlue + A2 * rgbtBlue); RgbtGreen := Round(A1 * ps^.rgbtGreen + A2 * rgbtGreen); RgbtRed := Round(A1 * ps^.rgbtRed + A2 * rgbtRed); End; Inc(pd); Inc(ps); End; End; End;
Установить размеры бумаги.
| Установить размеры бумаги |
Code: Var. Device, Driver, Port: array[0..80] of Char; DevMode: THandle; PDevmode: PDeviceMode; Begin. // Get printer device name etc. Printer.GetPrinter(Device, Driver, Port, DevMode); // force reload of DEVMODE. Printer.SetPrinter(Device, Driver, Port, 0) ; // get DEVMODE handle. Printer.GetPrinter(Device, Driver, Port, DevMode); If Devmode <> 0 Then Begin. // lock it to get pointer to DEVMODE record. PDevMode := GlobalLock( Devmode ); If pDevmode <> Nil Then. Try. With pDevmode^ Do Begin. // modify paper size. DmPapersize := DMPAPER_B5; // tell printer driver that dmPapersize field contains. // data it needs to inspect. DmFields := dmFields or DM_PAPERSIZE; End; Finally. // unlock devmode handle. GlobalUnlock( Devmode ); End; End; { If }. End;
©Drkb::03257.
| Установить размер шрифта для панели StatusBar. |
Code: With StatusBar1.Panels[1] do. Begin. Text := Edit1.Text; Canvas.Font.Size := StatusBar1.Font.Size; Width := Canvas.TextWidth(Text) + 10; End;
| Установить звук для TMediaPlayer. |
Code: Uses. MPlayer, MMSystem; Const. MCI_SETAUDIO = $0873; MCI_DGV_SETAUDIO_VOLUME = $4002; MCI_DGV_SETAUDIO_ITEM = $00800000; MCI_DGV_SETAUDIO_VALUE = $01000000; MCI_DGV_STATUS_VOLUME = $4019; Type. MCI_DGV_SETAUDIO_PARMS = record. DwCallback: DWORD; DwItem: DWORD; DwValue: DWORD; DwOver: DWORD; LpstrAlgorithm: PChar; LpstrQuality: PChar; End; Type. MCI_STATUS_PARMS = record. DwCallback: DWORD; DwReturn: DWORD; DwItem: DWORD; DwTrack: DWORD; End; Procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer); { Volume: 0 - 1000 }. Var. P: MCI_DGV_SETAUDIO_PARMS; Begin. { Volume: 0 - 1000 }. P.dwCallback := 0; P.dwItem := MCI_DGV_SETAUDIO_VOLUME; P.dwValue := Volume; P.dwOver := 0; P.lpstrAlgorithm := nil; P.lpstrQuality := nil; MciSendCommand(MP.DeviceID, MCI_SETAUDIO, MCI_DGV_SETAUDIO_VALUE or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p)); End; Function GetMPVolume(MP: TMediaPlayer): Integer; Var. P: MCI_STATUS_PARMS; Begin. P.dwCallback := 0; P.dwItem := MCI_DGV_STATUS_VOLUME; MciSendCommand(MP.DeviceID, MCI_STATUS, MCI_STATUS_ITEM, Cardinal(@p)); Result := p.dwReturn; { Volume: 0 - 1000 }. End; // Example, Beispiel: Procedure TForm1.Button1Click(Sender: TObject); Begin. SetMPVolume(MediaPlayer1, 500); End;
©Drkb::01319.
Взято с сайта: http://www.swissdelphicenter.ch.
Утечка памяти при поиске файлов.
| Утечка памяти при поиске файлов |
Не забывайте вызывать SysUtils.FindClose(SearchRec) после каждого вызова FindFirst, так как вызов FindFirst создаёт динамическую структуру SearchRec, которую после поиска надо освобождать.
©Drkb::03135.
Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).
Турбо Дельфи.
| Турбо Дельфи |
Что такое серия Turbo? Это новый маркетинговый ход компании Borland, направленный на усиление и расширение своих позиций на рынке софта для разработчиков. Что это собой представляет. По сути это BDS2006, разделённая на отдельные блоки. Большинству программистов просто не нужны все языки в одном флаконе. Да ещё за такие деньги. Серия Turbo представляет собой 4 отдельных продукта: Turbo Delphi Turbo C++ Turbo Delphi for .NET Turbo C# Всё это существует в 2-х версиях: Professional и Explorer. Стоимость Professional - 399$, Explorer Бесплатна для любого использования, в том числе и коммерческого. Всё различие между ними - в наличии разблокирующего кода. Что мы теряем, не заплатив 399$? Какие ограничения найдены: * Нет компилятора коммандной строки * Отключена установка компонентов через IDE Ну первый многим не особо нужен, немногие даже не знают о его существовании. Так что это условный минус. Второй минус: Да, через иде не поставить. Но можно спокойно прописать свои компоненты в файле dclusr.dpk любым текстовым редактором. Такая правка вполне законна. Так что этот минус тоже весьма условный. Примечание: Borland выпустила патч, "исправляющий" эту "ошибку". Ставить его или нет - дело ваше. Если ставить, то сохраните резервную копию файла dclusr.res и восстановите его после апдейта. Также замечено: Получая ключ от Borland, можно заметить, что там оговорен момент установки Turbo под линукс! Предпологаю, что сама среда написана на managed .NET коде, и имеет возможность работать под Linux, на mono. Созданные .NET приложения, также должны работать под mono, если не используют unmanaged кода. Это предположение пока не проверено. Если у кого есть возможность - проверьте пожалуйста. Итог: Нам подарили практически полноценные Delphi 2006 и Builder 2006. Теперь мы можем создавать свои собственные продукты бесплатно и легально. Хвала Борланду! Также мы получили платный пакет ценой не в 3-4 тысячи уёв, а 399$. Что гораздо более реально. Также существуют платные версии для студентов и учебных заведений, на случай, если им недостаточно бесплатного пакета, стоимостью менее 100$ Счастья Вам и Delphi в каждый дом ;-) Скачать продукты серии Turbo можно с оффсайта: http://www.turboexplorer.com/ Получить бесплатный ключ можно на сайте Борланда http://members.borland.com/download/trial.aspx?sid=622 Особо ленивые могут взять в аттаче ;-) Ключ нужно положить в свою домашнюю папку: "D&S\Имя_юзера\" Дополнительно прилагается официальный FAQ, переведённый на русский. Turbo 2006 FAQ В. О каких новых продуктах объявлено отделом средств разработки корпорации Borland? О. Представлено новое семейство продуктов «Turbo Delphi», «Turbo Delphi .NET», «Turbo C++» и «Turbo C#». Для каждого из этих продуктов предусмотрено два выпуска — Explorer Edition и Professional Edition. В. Для кого предназначены эти продукты? O. Версии Turbo Explorer — это готовые решения для студентов, любителей и непрофессионалов, желающих быстро освоиться с программированием для Windows и .NET на языках C++, C# и Delphi. Версии Turbo Professional предназначены для энтузиастов и независимых профессионалов, которым требуются наиболее гибкие, мощные и удобные среды разработки приложений для Windows и .NET. В. Чем версии Turbo Professional отличаются от Borland Developer Studio (BDS) Professional Edition? О. Продукты Turbo Professional — это решения для одного языка и одной платформы, предназначенные для разработчиков-любителей, независимых профессиональных разработчиков и профессионалов, работающих по совместительству. Borland Developer Studio (BDS) — это многоязыковая и многоплатформенная среда разработки с поддержкой языков C++, C# и Delphi. Она позволяет создавать приложения для платформ Windows и Windows .NET. В. Будут-ли выпущены Turbo Enterprise или Architect? O. Нет. Enterprise и Architect доступны только в виде Borland Develpper Studio. В данный момент нет планов по выпуску Enterprise или Architect для Turbo. В. Чем отличаются выпуски Explorer и Professional? O. Основное различие заключается в том, что выпуски Explorer поставляются с ограниченным набором программных компонентов (более 200) для создания приложений различных типов, ограниченных только воображением разработчика. В комплект поставки продуктов Professional входят несколько дополнительных компонентов, но гораздо важнее то, что версии Professional позволяют настраивать эти компоненты, а также создавать свои собственные и загружать любые компоненты и элементы управления из тысяч доступных от сторонних разработчиков. Продукты Professional также позволяют использовать модули интегрированной среды разработки (IDE), сотни которых поставляются сторонними разработчиками и позволяют расширить функциональные возможности IDE. Цена Explorer: Бесплатно Professional: 399 долларов США Компоненты Explorer: Сотни компонентов входят в комплект поставки. Нельзя добавлять дополнительные компоненты. (! (моя ремарка) нельзя через IDE) Professional: Все компоненты в Explorer. InterBase Express, Indy и IntraWeb, а также примеры дополнительных компонентов. Можно добавлять дополнительные компоненты. (! Как я уже говорил, пакеты идентичны, различаются только разблокирующим кодом. Соответственно все компоненты есть в обоих вариантах, только в Explorer они не вынесены на панедь компонентов в IDE) Дополнительное ПО Explorer: InterBase для разработчиков Professional: InterBase для разработчиков, Rave Reports, Remote Debugger (! вот пожалуй исключение - доп софт поставляется только в CD версиях) Только для Turbo C++ Explorer: Ограниченная функциональность ActiveX/COM Professional: Расширенные серверные функции ActiveX/COM В. Предусмотрены ли обновления до серии Turbo для существующих клиентов? О. Turbo Professional — это совершенно новая серия продуктов, цена на которые установлена специально для независимых и новых разработчиков. Предполагается, что расценки на обновление будут доступны для последующих версий. Пользователи продуктов Turbo Explorer могут приобрести продукты Turbo Professional и обновить свои версии Turbo Explorer до Professional с помощью программного ключа лицензии. В. Как превратить версию Turbo Explorer Edition в Turbo Professional Edition? О. Приобретая версию Turbo Professional Edition, вы получаете ключ лицензии, который можно ввести в поле диспетчера лицензий, чтобы «разблокировать» дополнительные функции Turbo Explorer — в том числе доступ к дополнительным компонентам и возможность добавления новых компонентов. Загрузив версию Professional либо купив ее на компакт- или DVD-диске, вы также получите дополнительное ПО, включая программы для удаленной отладки, Rave Reports, а для Turbo C++ — дополнительные серверные возможности ActiveX/COM. В. Можно ли обновить созданные ранее проекты на Delphi, C++Builder и C#Builder до Turbo Professional? О. Да, с помощью соответствующего продукта Professional можно открывать и использовать приложения C++, C# и Delphi/.NET, созданные в BDS (Borland Developer Studio) 2006 и более ранних версиях этого приложения, в том числе — C++Builder и Delphi. В. Можно ли использовать компоненты и элементы управления VCL для Delphi и C++Builder? О. Да, продукты Turbo Professional совместимы с дополнительными элементами управления VCL и компонентами Borland Developer Studio 2006, в том числе с компонентами, созданными сторонними разработчиками. В. Можно ли одновременно установить на ПК более одного продукта серии Turbo? О. На ПК или виртуальную машину можно одновременно установить только один продукт серии Turbo. В. Можно ли использовать продукт Turbo Explorer Edition для разработки коммерческих приложений? О. Да. С помощью продуктов Explorer Edition можно разрабатывать ПО для личного и коммерческого использования. В. Как можно приобрести продукты серии Turbo? О. Версии Turbo Explorer доступны для загрузки. Они также доступны на бесплатных компакт-дисках и компакт-дисках, прилагаемых к журналам. Версии Turbo Professional можно приобрести у дилеров Borland/DevCo, а также в Интернет-магазине. В. Можно ли получить коробочную версию Turbo Professional, если есть желание приобрести и носитель? О. Да, эти версии можно приобрести обычным способом у дилеров и партнеров корпорации Borland, а также через Интернет. В. Можно ли заказать обслуживание продуктов серии Turbo? О. Да, обслуживание продуктов серии Turbo осуществляется на обычных условиях программы Software Assurance (включающих обслуживание и техническую поддержку). Его можно включить в существующий договор поддержки.
Материал предоставил Snow Silence.
Sources.ru.
©Drkb::00337.
Ходил вчера на конференцию. А скачал еще раньше. Поясняю: Turbo - это кусок из Borland Developer Studio 2006. Ставить можно что-либо одно, и BDS2006 быть не должно. Это, на мой взгляд, самый большой недостаток. Который, впрочем, решается Что-нить одно - это из набора Delphi win32 or .NET, C++ win32 or .NET, C#. IDE у всех продуктов работает под .NET. Поэтому исходный вид - как у Visual Studio, но можно и привести к более-менее привычному. Вообще говоря, на конференции показывали Delphi win32, и позиционировали, в частности, как замену Delphi 7 "Возвращаться к D7 не захочется". Наверно, могу подтвердить - вкусностей много и недорого Правда, продукт рассчитан явно на одного разработчика: нет ничего для групповой разработки. Из вкусностей, что показывали и что понравилось (я не до всего долез): 1. история изменений. Фактически - bak хранятся в отдельном каталоге, с установленной глубиной. Можно просматривать и есть сравнение. То есть, нажал сохранить модуль, потом всегда можно посмотреть, что изменилось. Что-то вроде локального cvs. К формам тоже относится 2. Интеллектуальные шаблоны. Кто работал с mcad - там примерно так же, через TAB 3. Рефакторинг, интеллектуальный поиск 4. Улучшенный менеждер памяти. Впрочем, все вышеперечисленное есть и в BDS2006 Еще раз подчеркнули: да, на Turbo Explorer можно делать коммерческие разработки. Насчет связи с БД: в эксплорере есть dbExpress и ADO. В профе добавляется IBX и BDE (или BDE есть и в эксплорере? Не помню - мне не нать). Немного мутно насчет DataSnap: исходники есть все, а вот визардов вроде нет. Впрочем, проф. версию я не смотрел, может, там и есть. Немного мутно насчет Rave reports: четко указано, что есть в проф. версии C++, для остальных - не ведаю.
Romkin.
Sources.ru.
©Drkb::00338.
| Функции для работы с объектом типа TImage. |
Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Функции для работы с объектом типа TImage. Модуль ImgTools предоставляет функции для работы с изображениями, В частности для работы с визуальным объектом типа TImage. Function FitBestSize - Подбор оптимального размера рисунка, В соответствии с областью на которой он расположен. Function CenterImage - Центрирование рисунка в области, на которой он расположен. Function SetImageSize - Процентное изменение размера рисунка. Каждая функция возвращает результат типа TImageSizeParams; Type TImageSizeParams = record. OldImageWidth - ширина рисунка до преобразований. OldImageHeight - высота рисунка до преобразований. OldImageLeft - позиция X рисунка до преобразований. OldImageTop - позиция Y рисунка до преобразований. NewImageWidth - ширина рисунка после преобразований. NewImageHeight - высота рисунка после преобразований. NewImageLeft - позиция X рисунка после преобразований. NewImageTop - позиция Y рисунка после преобразований. NewImageSizePercent - размер рисунка в процентах после преобразования, От размера рисунка до преобразования. End; Зависимости: ExtCtrls. Автор: VID, vidsnap@mail.ru, ICQ:132234868, Махачкала. Copyright: VID. Дата: 05 мая 2002 г. ***************************************************** } Unit ImgTools; Interface. Uses ExtCtrls; Type. TImageSizeParams = record. OldImgWidth, OldImgHeight, OldImageLeft, OldImageTop, NewImgWidth, NewImgHeight, NewImageLeft, NewImageTop, NewImgSizePercent: Integer; End; Type. TTimeState = (tsBefore, tsAfter); Function FitBestSize(Img: TImage): TImageSizeParams; Function CenterImage(Img: TImage): TImageSizeParams; Function SetImageSize(Img: TImage; SizePercent: Integer): TImageSizeParams; Var. ImageSizeParams: TImageSizeParams; Implementation. //Обнуление полей переменной типа TImageSizeParams. Function ClearImageSizeParams: TImageSizeParams; Begin. Result.OldImgWidth := 0; Result.OldImgHeight := 0; Result.OldImageLeft := 0; Result.OldImageTop := 0; Result.NewImgWidth := 0; Result.NewImgHeight := 0; Result.NewImageLeft := 0; Result.NewImageTop := 0; Result.NewImgSizePercent := 0; End; //Получение параметров рисунка до и после преобразований. Function GetImageSizeParams(Img: TImage; TimeState: TTimeState): TImageSizeParams; Begin. If img = nil then. Begin. Result := ClearImageSizeParams; ImageSizeParams := Result; Exit; End; If TimeState = tsBefore then. Begin. ImageSizeParams := ClearImageSizeParams; Result.OldImgWidth := img.Width; Result.OldImgHeight := img.Height; Result.OldImageLeft := img.Left; Result.OldImageTop := img.Top; End; If TimeState = tsAfter then. Begin. Result := ImageSizeParams; Result.NewImgWidth := img.Width; Result.NewImgHeight := img.Height; Result.NewImageLeft := img.Left; Result.NewImageTop := img.Top; Result.NewImgSizePercent := Round(Result.NewImgWidth / Result.OldImgWidth * 100); End; ImageSizeParams := Result; End; //Подбор оптимального размера рисунка, в соответствии с областью на которой он расположен. Function FitBestSize(Img: Timage): TImageSizeParams; Var. H, w, i, x, y: Integer; K, b, a: Double; Begin. If Img = nil then. Exit; Try. Result := ClearImageSizeParams; Img.AutoSize := True; Img.AutoSize := False; GetImageSizeParams(Img, tsBefore); H := img.picture.Height; W := img.picture.Width; I := 0; Repeat. X := img.Parent.clientwidth - w; Y := img.Parent.clientheight - h; I := i + 1; K := w / h; If y < x then. Begin. B := y; H := h + Round(b); A := H * k - W; W := w + Round(a); End; If y >= x then. Begin. A := x; W := w + Round(a); B := (w / k) - H; H := h + Round(b); End; Until (w < img.Parent.width) or (h < img.Parent.height) or (i >= 2); Img.Stretch := true; Img.Width := w; Img.height := h; Result := GetImageSizeParams(Img, tsAfter); Except. End; End; //Центрирование рисунка в области, на которой он расположен. Function CenterImage(Img: TImage): TImageSizeParams; Begin. Result := ClearImageSizeParams; If Img = nil then. Exit; GetImageSizeParams(img, tsBefore); Img.left := (Img.parent.Width div 2) - (img.Width div 2); Img.Top := (Img.parent.Height div 2) - (img.height div 2); Result := GetImageSizeParams(img, tsAfter); End; //Процентное изменение размера рисунка. Function SetImageSize(Img: TImage; SizePercent: Integer): TImageSizeParams; Var. K: Double; Nw, nh: Integer; Begin. Result := ClearImageSizeParams; If Img = nil then. Exit; If SizePercent < 0 then. Exit; Img.AutoSize := True; Img.AutoSize := False; GetImageSizeParams(img, tsBefore); Try. K := img.height / img.width; Except exit; End; Nw := Round(img.Width * SizePercent / 100); Nh := round(nw * k); Img.Stretch := true; Img.Width := nw; Img.Height := nh; Result := GetImageSizeParams(img, tsAfter); End; End.
| Функции для выделения, перераспределения и освобождения памяти |
Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Функции для выделения/перераспределения/освобождения памяти. Модуль содержит функции для работы с блоками памяти. AllocateMem - выделяет блок памяти из Count записей по RecSize байт, возвращает. Адрес выделенного блока памяти в случае успеха или nil в случае ошибки. ReallocateMem - устанавливает новый размер блока памяти, выделенного функцией. AllocateMem. В качестве параметра Pointer можт быть использован как. Типизированный так и нетипизированный указатель. DeallocateMem - освобождает память, выделенную функциями AllocateMem или. ReallocateMem. В качестве параметра Pointer можт быть использован как. Типизированный так и нетипизированный указатель. MemSize - возвращает размер блока памяти, выделенного функциями AllocateMem или. ReallocateMem. Зависимости: Windows. Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург. Copyright: Dimka Maslov. Дата: 21 мая 2002 г. ***************************************************** } Unit MemFuncs; Uses Windows; Interface. Function AllocateMem(Count: Integer; RecSize: Integer): Pointer; Procedure ReallocateMem(var Pointer; Count: Integer; RecSize: Integer = 1); Procedure DeallocateMem(var Pointer); Function MemSize(P: Pointer): Integer; Implementation. Function LocalHandle; external kernel32 name 'LocalHandle'; Function AllocateMem(Count: Integer; RecSize: Integer = 1): Pointer; Asm. Test eax, eax. Jle @@10. Test edx, edx. Jle @@10. Imul edx. Push eax. Push LHND. Call LocalAlloc. Push eax. Call LocalLock. Ret. @@10: Xor eax, eax. End; Procedure ReallocateMem(var Pointer; Count: Integer; RecSize: Integer = 1); Asm. Push ebx. Mov ebx, eax. Mov eax, [ebx]. Test eax, eax. Jnz @@10. Mov eax, edx. Mov edx, ecx. Call AllocateMem. Mov [ebx], eax. Pop ebx. Ret. @@10: Push ecx. Push edx. Push eax. Call LocalHandle. Pop edx. Pop ecx. Test eax, eax. Jnz @@20. Pop ebx. Ret. @@20: Push eax. Mov eax, edx. Imul ecx. Mov edx, eax. Pop eax. Push LHND. Push edx. Push eax. Call LocalRealloc. Push eax. Call LocalLock. Mov [ebx], eax. Pop ebx. End; Procedure DeallocateMem(var Pointer); Asm. Push ebx. Mov ebx, eax. Mov eax, [ebx]. Test eax, eax. Jz @@10. Push eax. Call LocalHandle. Test eax, eax. Jz @@10. Push eax. Push eax. Call LocalUnlock. Call LocalFree. @@10: Xor eax, eax. Mov [ebx], eax. Pop ebx. End; Function MemSize(P: Pointer): Integer; Asm. Test eax, eax. Jnz @@10. Ret. @@10: Push eax. Call LocalHandle. Test eax, eax. Jnz @@20. Ret. @@20: Push eax. Call LocalSize. End; End.
| Функции для парсинга строк |
Здесь представлен модуль, в котором я разметил много методов для подобной работы. Некоторые функции поименованы по-шведски, но, может быть, Вы сможете понять, что они делают.
| Функция для разворачивания строк |
| Функция для удаления из строки лишних символов |
| Функция возвращающая N-ое слово в строке |
Code: //Функция возвращающая N-ое слово в строке. //Если N=0, то функция возвращает подстоку начиная с первого разделителя. Function GetWord(str:string;n:word;sep:char):string; Var i,space,l,j:integer; Buf:string; Begin. L:=length(str); If n=0 then begin //особый параметр. J:=pos(GetWord(str,2,sep),str); GetWord:=copy(str,j,l-j+1); Exit. End; Space:=0; I:=0; While (space<>(n-1))and(i<=l) do. Begin. I:=i+1; If str[i]=sep then space:=space+1. End; I:=i+1; Buf:=''; While (i<=l)and(str[i]<>sep) do. Begin. Buf:=buf+str[i]; I:=i+1. End; GetWord:=buf; End;
| Функция замены в строке всех вхождений одной подстроки на другую |
| Функция конвертации текста HTML содержащего строки вида # 123; в читабельбный вид |
Code: Function PreDecode(s:string):string; Function AddNumericChar(I: Integer):string; Var. W: WideChar; Buffer: array[0..10] of char; Begin. If I = 9 then result := ' ' Else if I < ord(' ') then result := '?' {control char}. Else if (I < 256) then result := Chr(I). Else. Begin. W := WideChar(I); SetString(result, Buffer, WideCharToMultiByte(CP_ACP, 0, @W, 1, @Buffer, SizeOf(Buffer), nil, nil)). End; End; Var val,i,ik:integer; sq:string; Begin. For i:=1 to Length(s) do. Begin. If ( (s[i]='&') and (s[i+1] ='#') ) then. Begin. Sq := Copy(s,i+2,length(s)); For ik:=1 to length(sq) do. Begin. If not ( sq[ik] in ['0'..'9'] ) then. Break; End; If Copy(sq,1,ik-1) <> '' then. Val := StrToInt( Copy(sq,1,ik-1) ) else val:=-1; If ( (val <> -1) and (sq[ik] = ';') ). Then. Begin. Result:=Result+AddNumericChar(val); Delete(s,i,ik+1); End; End else result:=Result+s[i]; End; End;
| Функция, которая нарисует на форме сетку и сделает форму похожей на дизайнер форм Delphi. |
Функция, которая нарисует на форме сетку и сделает форму похожей на дизайнер форм Delphi. По умолчанию в дизайнере Delphi отступы равны 8 пикселям
Code: Procedure TForm1.DrawGrid; Var. TmpBmp: TBitmap; Begin. TmpBmp := TBitmap.Create; Try. With TmpBmp Do. Begin. Width := 8; Height := 8; Canvas.Brush.Color := clBtnFace; Canvas.FillRect(TmpBmp.Canvas.ClipRect); Canvas.Pixels[0, 0] := clBlack; Canvas.Pixels[0, Height] := clBlack; Canvas.Pixels[Width, 0] := clBlack; Canvas.Pixels[Width, Height] := clBlack; End; With Canvas, Brush Do. Begin. Bitmap := TBitmap.Create; Try. Bitmap.Assign(TmpBmp); Canvas.FillRect(Canvas.ClipRect); Finally. Bitmap.Free; End; End; Finally. TmpBmp.Free; End; End; { Использование }. Procedure TForm1.FormPaint(Sender: TObject); Begin. DrawGrid; End;
| Функция передачи строк (а заодно и числа) между программами через SendMessage: |
Code: Function SendString(TargetWnd, SourceWnd: THandle; N: Integer; Const S: String): Integer; Var. CD: TCopyDataStruct; Begin. CD.dwData := N; CD.cbData := Length(S); If CD.cbData = 0 Then. CD.lpData := NIL. Else CD.lpData := @S[1]; Result := SendMessage(TargetWnd, WM_COPYDATA, SourceWnd, Integer(@CD)); End; ... Procedure WMCopyData(Var Msg: TWMCopyData); Message WM_COPYDATA; ... Procedure TForm1.WMCopyData(var Msg: TWMCopyData); Var. { Строка }. S: String; { Число }. N: Integer; Begin. If (Msg.CopyDataStruct^).lpData = NIL Then S := ''; SetLength(S,Msg.CopyDataStruct^.cbData); S := String((Msg.CopyDataStruct^).lpData); N := (Msg.CopyDataStruct^).dwData; End;
| Функция наполнения строки |
| Функция приблизительного (нечеткого) сравнения строк |
Автор: Дмитрий Кузан
| Функция проверки корректности ввода |
| Функция построения графика |
Code: Private. FPoints: array [0..144] of TPoint; {...} Procedure TForm1.CalculateGraph; Var. XRangePixels, yRangePixels: Integer; Origin: TPoint; Radian, interval: Double; I: Integer; Begin. { We calculate the sinus curve in the interval -2Pi..+2Pi, With a resolution of 4Pi/144, as a series of points that. Will be connected by a polyline. The graph is scaled to fit into. The paintbox. The origin of the coordinate system is the center. Of the paintbox. The default windows coordinate system is inverted, The Y axis points downward! } XRangePixels := (paintbox1.Width - 2) div 4; { pixels in Pi }. YRangePixels := (paintbox1.Height - 2) div 2; { pixels in 1 }. Origin := Point(paintbox1.Width div 2, paintbox1.Height div 2); Radian := -2.0 * Pi; Interval := 4.0 * Pi / 144.0; For i := 0 to High(FPoints) do. Begin. FPoints[i].X := origin.x + Round(radian * xRangePixels / Pi); FPoints[i].Y := origin.y - Round(sin(radian) * yRangePixels); Radian := radian + interval; End; End; Procedure TForm1.PaintBox1Paint(Sender: TObject); Var. Origin: TPoint; XRangePixels, yRangePixels: Integer; Begin. With PaintBox1.Canvas do. Begin. { Fill background in white }. Brush.Color := clBtnFace; Brush.Style := bsSolid; Fillrect(paintbox1.BoundsRect); { Paint a coordinate cross }. Origin := Point(paintbox1.Width div 2, paintbox1.Height div 2); Pen.Color := clBlack; Pen.Style := psSolid; Pen.Width := 1; MoveTo(1, origin.Y); LineTo(paintbox1.Width - 1, origin.y); MoveTo(origin.x, 1); LineTo(origin.x, paintbox1.Height - 1); { Paint some tickmarks and label the axis }. Font.Name := 'Symbol'; Font.Size := 8; Font.Color := clBlack; XRangePixels := (paintbox1.Width - 2) div 4; { pixels in Pi }. YRangePixels := (paintbox1.Height - 2) div 2; { pixels in 1 }. { X axis }. MoveTo(origin.x - 2 * xRangePixels, origin.y - 4); LineTo(origin.x - 2 * xRangePixels, origin.y + 4); TextOut(origin.x - 2 * xRangePixels + 2, origin.y + 2, '-2p'); MoveTo(origin.x - xRangePixels, origin.y - 4); LineTo(origin.x - xRangePixels, origin.y + 4); TextOut(origin.x - xRangePixels + 2, origin.y + 2, '-p'); MoveTo(origin.x + xRangePixels, origin.y - 4); LineTo(origin.x + xRangePixels, origin.y + 4); TextOut(origin.x + xRangePixels - 2 - TextWidth('p'), origin.y + 2, 'p'); MoveTo(origin.x + 2 * xRangePixels, origin.y - 4); LineTo(origin.x + 2 * xRangePixels, origin.y + 4); TextOut(origin.x + 2 * xRangePixels - 2 - TextWidth('2p'), origin.y + 2, '2p'); { Y axis }. MoveTo(origin.x - 4, origin.y - yRangePixels); LineTo(origin.x + 4, origin.y - yRangePixels); TextOut(origin.x + 4, origin.y - yRangePixels, '1.0'); MoveTo(origin.x - 4, origin.y - yRangePixels div 2); LineTo(origin.x + 4, origin.y - yRangePixels div 2); TextOut(origin.x + 4, origin.y - (yRangePixels + TextHeight('1')) div 2, '0.5'); MoveTo(origin.x - 2, origin.y + yRangePixels div 2); LineTo(origin.x + 2, origin.y + yRangePixels div 2); TextOut(origin.x + 3, origin.y + (yRangePixels - TextHeight('1')) div 2, '-0.5'); MoveTo(origin.x - 2, origin.y + yRangePixels); LineTo(origin.x + 2, origin.y + yRangePixels); TextOut(origin.x + 3, origin.y + yRangePixels - TextHeight('1'), '-1.0'); {Paint the graph }. Pen.Color := clBlue; Polyline(FPoints); End; End; Procedure TForm1.FormResize(Sender: TObject); Begin. CalculateGraph; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. CalculateGraph; End;
©Drkb::04224.
Взято с сайта: http://www.swissdelphicenter.ch.
| Туториал по DelphiX. |
Вступление
DelphiX - библиотека для Delphi основанная на Microsoft’овском DirectX. В настоящий момент, DelphiX поддерживает функции DirectX 1-7. Благодаря концепции DirectX, игры сделанные на более ранних версиях DirectX будут работать и на более поздних.
1. 
DXDraw.
Поверхность компоненты DXDRAW служит фундаментом для отображения графики.
1.1 Наиболее частая конфигурация
Align...................allClient.
AutoSize................True.
Display.
FixedBitCount........True.
Fixedratio...........True.
Fixedsize............False.
Options.
DoFullScreen.........True.
DoFlip...............True.
Rest.................False.
Если одновременно значения DoFullScreen и DoFlip сделать равными True, то кнопки управления окном не появятся (GDI=off). Если Вы хотите использовать кнопки, меню и т.д. можно сделать их в виде спрайтов. Если DoFlip=False, то включен оконный режим. Использование DoFullscreen и DoFlip делает игру очень быстрой по сравнению с игрой в оконном режиме.DXDrawSurface имеет тип TDirectDrawSurface. Эта поверхность также называется ' вторичной поверхностью ' или закадровой поверхностью, потому что она невидимая. Поверхность становится видимой после запроса метода DXDraw.Flip , в тот момент вторичная поверхность становится первичной. DXDraw.Primary - первичная (видимая) поверхность.
1.2 Режимы экрана
Текущая конфигурация видеорежима Windows не влияет на игровую конфигурацию. Все настройки осуществляются через DXDraw. Форма, на которой размещается DXDraw , должна иметь тип TDXForm.
1.2.1 Оконный режим
Для включения/выключения оконного/полноэкранного режимов служит опция [doFullScreen], посмотрите:
Code: Procedure TForm1.WindowMode; Begin. DXDraw1.Finalize; RestoreWindow; DXDraw1.Options := DXDraw1.Options - [doFullScreen]; DXDraw1.Display.Width := 640; DXDraw1.Display.Height := 480; DXDraw1.Display.BitCount := 8; DXDraw1.Initialize; End; DXDraw.Align := alClient; Form.ClientWidth := … // Установка ширины Формы/DХDrаw. Form.ClientHeight := … // Установка высоты Формы.
OpenGL для начинающих.
| OpenGL для начинающих |
************************************* ************ Часть I **************** ************************************* 00 Введение =========== Решив разобраться с OpenGL и просмотрев DRBK, я увидел печальную картину - то что там есть никак не дает пинка в нужном направлении для написания программ, использующих OpenGL. Ниже я постарался собрать в пучок результаты моих исследований и получил этот текст и MyOpenGL.pas. Я совсем не претендую на правильность терминов в описании и на то, как надо писать OpenGL-программы. Но простую OpenGL-программу вы точно сможете написать, использовав MyOpenGL.pas, после прочтения нижеследующего, как на VCL, так и на чистом WinAPI. Может кому пригодится для начала - написанное достаточно просто >:-) Были использованы следующие источники * Исходники Jan Horn (http://www.sulaco.co.za, http://home.global.co.za/~jhorn) В частности Skyboxes и Гаусово размытие. Второе уже есть в DRKB без имени автора Работа с графикой и мультимедиа > DerectX, OpenGL > OpenGL - радиальное размытие (названия функций, основа программы и много другое взяты оттуда). * Учебник по OpenGL (главы 1.3, 1.5) с www.ru-coding.com. * MS SDK > OpenGL Programmer's Reference, поставляемый вместе с Delphi (общая справка) * модуль EasyGL.pas Данилова Андрея (http://dasoft.land.ru) (своровал пару идей по оформлению VCL). * Статья по рисованию вращающего сердечка на OpenGL (не помню где брал). * Перевод Народного учебника по OpenGL от NeHe (http://nehe.gamedev.net). Брать тут - http://pmg.org.ru/nehe/nehehtml.zip (ну очень хороший учебник, хоть и на C; must see). 01 Контексты устройства и воспроизведения ========================================= "DC (Device Context - контекст устройства). Это то, на чём мы рисуем, и в Delphi контекст устройства представлен как TCanvas" (см. 1) Получить его можно следующим образом
Code: Var. DC: hDC; ... DC := GetDC(Form1.Hanle); Или. DC := Form1.Canvas.Handle;
"Графическая система OpenGL, как и любое другое приложение Windows, также нуждается в ссылке на окно, на котором будет осуществляться воспроизведение - специальной ссылке на контекст воспроизведения - величина типа HGLRC (Handle openGL Rendering Context, ссылка на контекст воспроизведения OpenGL). Для получения этого контекста OpenGL нуждается в величине типа HDC (контекст воспроизведения) окна, на который будет осуществляться вывод." Создать его можно следующим образом
Code: Uses OpenGL; ... Var. DC: hDC; RC: hGLRC; ... DC := GetDC(Form1.Handle); // получаем контекст устройства. SetDCPixelFormat(DC); // устанавливаем формат точки (см. 2). RC := wglCreateContext(DC); // создать новый контекст воспроизведения. WglMakeCurrent(DC, RC); // устанавливаем его текущим.
Здесь SetDCPixelFormat(DC) самописная функция, код см. в MyOpenGL.pas. Дополнительно 1. Работа с графикой и мультимедиа > GDI - графика в Delphi 2. Работа с графикой и мультимедиа > DerectX, OpenGL > Работа с OpenGL - Введение 3. Работа с графикой и мультимедиа > DerectX, OpenGL > Работа с OpenGL - Минимальная программа 02 Инициализация и завершение работы с OpenGL ============================================= Поскольку часть операций при инициализации зависит от размеров окна и должна повторяться при каждом изменении размеров окна, то эта часть вынесена в отдельную процедуру, которая выполняется при инициализации и при изменении размеров окна.
Code: {------------------------------------------------------------------} { Инициализация OpenGL }. {------------------------------------------------------------------} Procedure glInit(Wnd: hWND); Const. // Константы, задающие свойства материала фигур. Mat1_amb : array [0..2] of Single = (0.2, 0.2, 0.2); Mat1_dif : array [0..2] of Single = (0.8, 0.8, 0.0); Mat1_spec: array [0..2] of Single = (0.6, 0.6, 0.6); Mat1_shininess = 10; // Константы для источника света. Light_pos : array [0..3] of glFloat=(100.0, 100.0, 0.0, 1.0); Light_amb : array [0..3] of glFloat=(0.6, 0.6, 0.6, 1.0); Light_dif : array [0..3] of glFloat=(1.0, 1.0, 1.0, 1.0); Light_spec : array [0..3] of glFloat=(1.0, 1.0, 1.0, 1.0); Light_spot_direction : array [0..3] of glFloat=(1.0, 1.0, 1.0, 1.0); // Цвет тумана. FogColor: array [0..3] of GLfloat = (0, 1.0, 0, 1.0); Var. FogMode: GLint; Begin. // Инициализация контекста воспроизведения OpenGL. DC := GetDC(Wnd); // Получить контекст устройства для окна. SetDCPixelFormat(DC); // Установить формата пикселов. RC := wglCreateContext(DC); // создать новый контекст воспроизведения. WglMakeCurrent(DC, RC); // Установить его текущим. // Свойства материала для режима glEnable(GL_COLOR_MATERIAL). GlMaterialfv(GL_FRONT, GL_AMBIENT, @mat1_amb); GlMaterialfv(GL_FRONT, GL_DIFFUSE, @mat1_dif); GlMaterialfv(GL_FRONT, GL_SPECULAR, @mat1_spec); GlMaterialf (GL_FRONT, GL_SHININESS,mat1_shininess); // Свойства источника света GL_LIGHT1 для режима glEnable(GL_LIGHTING). // Стандартный источник одна команда: glEnable(GL_LIGHT0); GlLightfv(GL_LIGHT1, GL_POSITION,@light_pos); GlLightfv(GL_LIGHT1, GL_AMBIENT, @light_amb); // направленность. GlLightfv(GL_LIGHT1, GL_DIFFUSE, @light_dif); // рассеивание. GlLightfv(GL_LIGHT1, GL_SPECULAR, @light_spec); GlLightfv(GL_LIGHT1, GL_SPOT_DIRECTION, @light_spot_direction); // разрешить источник света GL_LIGHT1. GlEnable(GL_LIGHT1); // Свойства тумана для режима glEnable(GL_FOG). FogMode := GL_EXP; // GL_EXP2, GL_LINEAR. GlFogi(GL_FOG_MODE, fogMode); // установить режим. GlFogfv(GL_FOG_COLOR, @fogColor); // цвет тумана. GlFogf(GL_FOG_DENSITY, 0.002); // плотность - 0.2% GlHint(GL_FOG_HINT, GL_DONT_CARE); // GL_NICEST, GL_FASTEST. GlClearColor(0.0, 0.0, 0.2, 1.0); // Установить цвет фона - синий. GlClearDepth(1.0); // Очистить буфер глубины. GlDepthFunc(GL_LESS); // Тип теста глубины. GlShadeModel(GL_SMOOTH); // плавное цветовое сглаживание. // glEnable(..) - включить режим, glDisable(..) - отключить. GlEnable(GL_LIGHTING); // разрешить осещенность. //glEnable(GL_FOG); // разрешить тумана. GlEnable(GL_DEPTH_TEST); // разрешить тест глубины, с использованием. // функции определенной в glDepthFunc. GlEnable(GL_NORMALIZE); // разрешить нормали (различение передней. // и задней сторон плоских объектов). GlEnable(GL_COLOR_MATERIAL); // разрешить использование материалов на объектах. GlEnable(GL_TEXTURE_2D); // разрешить наложение текстур. //glEnable(GL_BLEND); // разрешить смешивание (напр. прозрачность). // не совместимо с glEnable(GL_DEPTH_TEST). GlLoadTexture('1.bmp', Texture); // загружаем текстуру. End; {------------------------------------------------------------------} { Обработчик на изменение размеров окна }. {------------------------------------------------------------------} Procedure glOnResize(Width, Height: Integer); Begin. If (Height = 0) then Height := 1; // Предупреждаем деление на 0. GlViewport(0, 0, Width, Height); // Устанавливаем область отображения. // на все окно. // Настройка матрицы проекции. GlMatrixMode(GL_PROJECTION); // Выбираем матрицу проекции. GlLoadIdentity(); // Устанавливаем ее единичной. // Устанавливаем тип проеции - Ортогональный. GlOrtho(-Width div 2, Width div 2, -Height div 2, Height div 2, -800, 800); // Настройка видовой матрицы. GlMatrixMode(GL_MODELVIEW); // Выбираем матрицу проекции. GlLoadIdentity(); // Устанавливаем ее единичной. End;
Инициализация OpenGL производится последовательным вызовом этих двух процедур - сначала gLInit (в ее начале происходит создание контекста воспроизведения, упомянутого в первой главе), а потом glOnResize. Отмечу, что включение/выключение режимов можно делать когда угодно, а не только при инициализации. Завершение работы с OpenGL проводит функция glKill.
Code: {------------------------------------------------------------------} { Завершение работы с OpenGL }. {------------------------------------------------------------------} Procedure glKill(Wnd: hWND); Begin. WglMakeCurrent(DC, 0); WglDeleteContext(RC); ReleaseDC(Wnd, DC); End;
03 Создание и рисование примитивов ================================== Ниже будет описан процесс отрисовки, использующий таймер. Сначала подготавливаем объекты сцены процедурой сферу и треугольник, а потом командой SwapBuffers(..) выводим сцену на экран. Для улучшения понимания здесь порезанный вариант MyOpenGL.glDraw.
Code: {------------------------------------------------------------------} { Создание объектов под отрисовку }. {------------------------------------------------------------------} Procedure glDraw(); Var. Obj: GLUquadricObj; Begin. // очистка Экрана и буфера глубины. GlClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); ... // Пример рисования разноцветного треугольника. GlBegin(GL_POLYGON); GlColor(0.0, 0.5, 0.0, 0.0); GlVertex3F(-50, -sqrt(3)*50, 0); // 1-я вершина. GlColor(0.5, 0.0, 0.0, 0.0); GlVertex3F(-100, -sqrt(3)*100, 0); // 2-я вершина. GlColor(0.0, 0.0, 0.5, 0.0); GlVertex3F(-125, -sqrt(3)*100, 0); // 3-я вершина. GlEnd; ... // Пример рисования сферы. GlColor(1.0, 1.0, 1.0, 0.5); // установить цвет объекта. Obj := gluNewQuadric; GluSphere(Obj, 100, 25, 25); // создать сферу R = 100, детализация - 25х25. ... // Выводим на экран подготовленную сцену. SwapBuffers(DC); End;
По таймеру выполняем
Code: GlDraw();
gluNewQuadric используется для создания объемных фигур одной командой
Code: Var. Obj : GLUquadricObj; ... Obj := gluNewQuadric; // Режимы отображения фигуры. GluQuadricDrawStyle(Obj, GLU_FILL); // GLU_POINT, GLU_LINE, GLU_SILHOUETTE. GluQuadricOrientation (Obj, GLU_INSIDE); // GLU_OUTSIDE. GluQuadricNormals (Obj, GLU_SMOOTH); // - нормаль для каждой точки. // GLU_FLAT - для сегмента. // GLU_NONE - не строить нормалей. GluQuadricTexture(Obj, GL_TRUE); // - разрешить наложение текущей текстуры. // Создание фигуры. GluSphere(Obj, 100, 25, 25); // сфера R = 100, детализация - 25х25. Или. GluCylinder(Obj, 10, 100, 150, 30, 1); // цилиндр - R0 = 10, R1 = 100, H = 150, детализация - 30 плоскостей. Или. GluDisk(Obj, 10, 100, 30, 1); // Диск - R0 = 10, R1 = 100, детализация - 100. Или. GluPartialDisk(Obj, 10, 100, 30, 100, 0, 120); // треть диска с параметрами как у верхнего. ... //Освобождаем память. GluDeleteQuadric(Obj);
Quadric-объекты являются надстройкой над конструкцией glBegin-glEnd. Для glBegin определены следующие константы (подробнее см. SDK OpenGL) GL_POINTS - последовательность точек GL_LINES - линии (пара точек; пара точек) GL_LINE_STRIP - ломаная (аналог последовательности lineto) GL_LINE_LOOP - замкнутая GL_TRIANGLES - треугольник GL_TRIANGLE_STRIP - объединенная группа треугольников GL_TRIANGLE_FAN GL_QUADS - четырехугольник GL_QUAD_STRIP - объединенная группа четырехугольников GL_POLYGON - плоский полигон Так же стоит обратить внимание на glPolygonMode, позволяющий по различному отображать строемую фигуру (см. код для Quadric) 04 Преобразования координат и проекции ======================================
Цитата
Q: Возникла такая ситуация. Есть несколько объектов. Hyжно повеpнyть некотоpые из них. Функция glRotate() повоpачивает всю сценy. Сyществyет ли функция, котоpая повоpачивает только некотоpые (не все) вершины? "Для задания различных преобразований объектов сцены в OpenGL используются операции над матрицами, при этом различают три типа матриц: видовая, проекций и текстуры. Все они имеют размер 4x4" В каждый момент можем работать только с одним из типов матрицы. Выбрать нужную можно следующим образом
Code: // mode = // GL_MODELVIEW - выбрать видовую матрицу. // GL_PROJECTION - выбрать матрицу проекций. // GL_TEXTURE - выбрать матрицу текстур. GlMatrixMode(<mode>);
По умолчанию все матрицы нулевые, поэтому при инициализации их заполняем, разумеется выбрав сначала тип матрицы. Можно заполнить какой-то конкретной или просто единичной, как в MyOpenGL.glInit. (Единичная - это та, у которой на диагонали единицы, а остальные нули).
// отличие glLoadMatrixf от glLoadMatrixg заключается в том, как будет
// восприниматься входной массив, определяющий матрицу
// так - <строка1>, <строка2>, <строка3>, <строка4>
// или так - <столбец1>, <столбец2>, <столбец3>, <столбец4>
GlLoadMatrixf(<указатель на массив из 16 элементов типа double>);
или
GlLoadMatrixg(<указатель на массив из 16 элементов типа double>);
или
GlLoadIdentity(); // заполнение единичной
" Часто нужно сохранить содержимое текущей матрицы для дальнейшего использования, для чего используют команды".
GlPushMatrix(); // сохранить матрицу (в стеке).
GlPopMatrix(); // извлечь матрицу (из стека).
Вспоминаем, что такое стек 
)
Для GL_MODELVIEW-матриц глубина стека не менее 32, для других типов не менее 2.
Далее попробую объяснить для чего нужны различные матрицы и как их использовать.
Итак, задача такова, что надо создать трехмерную фигуру, изменить ее и потом
отобразить на плоскость окна. Реализация OpenGL такова, что при этом имеем четыре
перехода из одних координат в другие.
Координаты объекта (4D) => Видовые координаты (4D) => Усеченные координаты (4D) =>
Нормализованные координаты (3D) => Оконные координаты (2D)
(4D - это точка имеет 4 координаты, первые 3 - ее 3D координаты, последняя
дополнительная составляющая).
Переход от координат объекта к видовым осуществляется при использовании GL_MODELVIEW
матрицы. По видовым координатам вычисляются усеченные координаты, используя GL_PROJECTION
матрицу (название усеченные координаты идет от того, что для любой точки фигуры
(x1, x2, x3, x4), верно -1 <= x_i <= 1, то есть GL_PROJECTION матрица отображает фигуру
в 4D-куб c длиной стороны 2 и центром в (0, 0, 0, 0)). Нормализванные координаты
получаются из усеченных следующим преобразованием
(x1', x2', x3') = (x1/x4, x2/x4, x3/x4).
Размер окна, куда будет отображаться фигура заданная в нормализованных координатах,
определяется функцией glViewPort.
Теперь, думаю, код glOnResize достаточно понятен.
Code: // 1. GlViewport(0, 0, Width, Height); // Устанавливаем область отображения. // на все окно. // 2. // Настройка матрицы проекции. GlMatrixMode(GL_PROJECTION); // Выбираем матрицу проекции. GlLoadIdentity(); // Устанавливаем ее единичной. // Устанавливаем тип проеции - Ортогональный. GlOrtho(-Width div 2, Width div 2, -Height div 2, Height div 2, -800, 800); // 3. // Настройка видовой матрицы. GlMatrixMode(GL_MODELVIEW); // Выбираем матрицу проекции. GlLoadIdentity(); // Устанавливаем ее единичной.
Блоки 1, 2 и 3 можно менять местами. Единственное отличие, если поменять местами 2 и 3, то что текущая матрица будет не GL_MODELVIEW, а GL_PROJECTION. Примечание: GL_PROJECTION матрицу лучше выбирать так, чтобы * GL_MODELVIEW была единичной; * исходные размеры объекта были в пределах отрезка [-1; 1].
Цитата
A: Для того, чтобы пpименить pазные пpеобpазования к pазным объектам сцены, надо делать так:
GlMatrixMode(GL_MODELVIEW);
GlLoadIdentity();
GlRotate, glScale, glTranslate // ... --- в общем, всё что нyжно...
Затем pисyешь объекты... После того, как наpисовал, yказываешь новое пpеобpазование:
GlLoadIdentity(); glRotate, glScale, glTranslate // ...
Снова pисyешь объекты. И так повтоpяешь, сколько надо. А теперь все это так, как было бы в коде (напр. в MyOpenGL.glDraw).
Code: // Указываем, что работать будем с видовой матрицей. // Если она и так была текущей, то можно не выполнять. GlMatrixMode(GL_MODELVIEW); // Сбрасываем до единичной. // (Считаем, что GL_PROJECTION подобрана, как указано выше). GlLoadIdenty(); GlTranslatef(100.0, 0.0, 0.0); // Добавим к матрице перенос на 100 вдоль ОХ. GlPushMatrix; // сохраняем матрицу в стек - она нам еще понадобится. ... // Рисуем какую-нить фигуру1. ... GlRotate (-90, 0.0 , 1.0, 0.0); // Поворот на -90 градусов вокруг оси OY. GlRotate(60, 1.0, 0.0, 0.0); // Поворот на 60 градусов вокруг оси OX. ... // Рисуем фигуру2. ... GlPopMatrix; // восстанавливаем матрицу из стека. ... GlTranslatef(0.0, 10.0, 0.0); // двигаем на 10 по оси OX. ... // Рисуем фигуруЗ. ...
После этого имеем - фигура1 перенесена от центра на 100 по оси ОХ. Фигура2 имеет матрицу - соответствующую следующим последовательным действиям: перенос на 100, поворот, поворот. glPopMatrix - возвращает нас к исходной матрице, содержащей только перенос на 100, потому GL_MODELVIEW-матрица у фигуры3 - это перенос на 100 + перенос на 10 по оси ОY. Вообще говоря, последовательность неких действий - это домножение исходной матрицы на матрицы, отвечающие этим действиям. Поскольку умножение матриц некоммуникативно (AB <> BA), то и при смене чередовании элементов последовательности, получим другой результат. Дополнительно - www.ru-coding.com/ogl_1_3.php 04а GL_PROJECTION ================= Считаем, что GL_MODELVIEW матрица единичная. Задание матрицы проекции, которое могло быть напр. в MyOpenGL.glOnResize Перспективная проекция
Code: GlFrustum( - Width div 2, Width div 2, - Height div 2, Height div 2, 100, 300); GlTranslatef(0, 0, -200);
Ортогональная проекция
Code: GlOrtho(- Width div 2, Width div 2, -Height div 2, Height div 2, -800, 800);
Примерный смысл для параметров команд glFrustum и glOrtho. Первые четыре, расписанные как (left, top) и (right, bottom) определяют прямоугольник. Лучше представить его как окно, через которое мы смотрим на мир (т. е. на группу объектов, которые были получены при преобразовании их исходных координат их GL_MODELVIEW-матрицами). Чем оно больше (больше значения параметров), тем больше объекты (по размерам) можем видеть (по другому - как будто отходим назад от объектов). При симметричных координатах - смотрим на центр. Если провести через все углы линии ортогональные прямоугольнику, то высекаемый ими объем будет тем, что мы видим в мире. Поскольку объекты в бесконечности никого не интересуют (напр. не видны из-за малого размера при перспективной проекции), то логично ввести плоскость, параллельную плоскости окна и если объект оказался за ней, то забыть о его существовании - это сильно упрощает OpenGL расчеты. Логично ввести такую же плоскость и для объектов сблизи (хотя бы из соображений симметрии ;-)), т. е. если объект ближе чем она, то он не выводится. Пятый и шестой параметры - как раз и задают расположение второй и первой плоскости: при перспективной проекции - как растояние от окна до требуемых плоскостей (следствие: всегда пятый параметр меньше шестого и оба больше 0), при ортогональной - расстояние от начала координат (поскольку при ортогональной проекции нет искажении из-за того как далеко от нас находится центр, то можно представить его где-либо перед нами и соответсвенно задать координаты плоскостей отсечения). Если мы рисуем объекты вокруг центра координат, напр. так создаются Quadric-объекты, то для перспективной проекции также надо добавить сдвиг, помещающий центр координат МЕЖДУ плоскостями отсечения (этот же сдвиг можно сделать и в GL_MODELVIEW матрице). Для ортогональной этого делать не надо - центр и так где-то перед нами. Другой способ задавать перспективную проекцию - это воспользоваться gluPerspective. Примечание: чем меньше расстояние между плоскостями отсечения, тем быстрее все считается. 05 Текструры ============ Текстуру сначала надо загрузить и получить ее идентификатор (хендл). перед созданием объекта текстура выбирается по своему идентификатору (делается текущей) и автоматом прилепляется к объекту (GLUquadricObj).
Code: Uses. OpenGL; ... Var. Texture: glUint; ... // функция для установки текущей текстуры по идентификатору texture. // в openGL.pas ее почему то нет :(, потому импортируем. Procedure glBindTexture(target: GLenum; texture: GLuint); stdcall; external opengl32; ... // Где-то вначале программы, перед использованием glDraw. LoadTexture('1.bmp', Texture); ... {------------------------------------------------------------------} { Создание объектов под отрисовку }. {------------------------------------------------------------------} Procedure glDraw(); Var. Obj : GLUquadricObj; Begin. ... // 1-ый вариант. GlBindTexture(GL_TEXTURE_2D, Texture); // устанавливаем текущую текстуру Texture. Obj:=gluNewQuadric; GluQuadricTexture(Obj, GL_TRUE); // при создании объекта наложить текущую текстуру. GluSphere(Obj, 100, 25, 25); // создать сферу R = 100, детализация - 25х25. ... Или так. ... // 2-ой вариант. GlBindTexture(GL_TEXTURE_2D, Texture); // устанавливаем текущую текстуру Texture. // Рисуем фигуру, на которую наложится текстура при помощи glTexCoord2f. GlBegin(GL_QUADS); GlNormal3f( 0.0, 0.0, 1.0); // 1-я точка текстуры + 1-я точка объекта. GlTexCoord2f(0.0, 0.0); GlVertex3f(-100.0, -100.0, 0.0); // 3-я точка текстуры + 2-я точка объекта. GlTexCoord2f(1.0, 0.0); GlVertex3f( 100.0, -100.0, 0.0); // 3-я точка текстуры + 3-я точка объекта. GlTexCoord2f(1.0, 1.0); GlVertex3f( 100.0, 100.0, 0.0); // 1-я точка текстуры + 1-я точка объекта. GlTexCoord2f(0.0, 1.0); GlVertex3f(-100.0, 100.0, 0.0); GlEnd();
При этом должен быть разрешен режим наложения текстур (по умолчанию - отключен)
GlEnable(GL_TEXTURE_2D);
Примечание: Функция MyOpenGL.glLoadTexture поддерживает загрузку только 8 и 24-битных изображений. Дополнительно www.ru-coding.com/ogl_1_5.php 06 Unit MyOpenGL.pas ====================
Code: Unit MyOpenGL; Interface. Uses windows, OpenGL; Procedure glOnResize(Width, Height : Integer); Procedure glInit(Wnd: hWND); Procedure glKill(Wnd: hWND); Procedure glDraw(); Procedure glLoadTexture(Filename: String; var Texture: GLuint); Implementation. Procedure glBindTexture(target: GLenum; texture: GLuint); stdcall; external opengl32; Function gluBuild2DMipmaps(Target: GLenum; Components, Width, Height: GLint; Format, atype: GLenum; Data: Pointer): GLint; stdcall; external glu32; Procedure glGenTextures(n: GLsizei; var textures: GLuint); stdcall; external opengl32; Procedure SetDCPixelFormat(DC: hDC); forward; Var. DC: hDC; // контекст устройства. RC: hGLRC; // контекст воспроизведения. Texture: GLuint; // хэндл текстуры. Angle: Integer = 0; // угол поворота сферы. {------------------------------------------------------------------} { Обработчик на изменение размеров окна }. {------------------------------------------------------------------} Procedure glOnResize(Width, Height: Integer); Begin. If (Height = 0) then Height := 1; // Предупреждаем деление на 0. GlViewport(0, 0, Width, Height); // Устанавливаем область отображения. // на все окно. // Настройка матрицы проекции. GlMatrixMode(GL_PROJECTION); // Выбираем матрицу проекции. GlLoadIdentity(); // Устанавливаем ее единичной. // Устанавливаем тип проеции - Ортогональный. GlOrtho(-Width div 2, Width div 2, -Height div 2, Height div 2, -800, 800); // Настройка видовой матрицы. GlMatrixMode(GL_MODELVIEW); // Выбираем матрицу проекции. GlLoadIdentity(); // Устанавливаем ее единичной. End; {------------------------------------------------------------------} { Инициализация OpenGL }. {------------------------------------------------------------------} Procedure glInit(Wnd: hWND); Const. // Константы, задающие свойства материала фигур. Mat1_amb : array [0..2] of Single = (0.2, 0.2, 0.2); Mat1_dif : array [0..2] of Single = (0.8, 0.8, 0.0); Mat1_spec: array [0..2] of Single = (0.6, 0.6, 0.6); Mat1_shininess = 10; // Константы для источника света. Light_pos : array [0..3] of glFloat = (100.0, 100.0, 0.0, 1.0); Light_amb : array [0..3] of glFloat = (0.6, 0.6, 0.6, 1.0); Light_dif : array [0..3] of glFloat = (1.0, 1.0, 1.0, 1.0); Light_spec : array [0..3] of glFloat = (1.0, 1.0, 1.0, 1.0); Light_spot_direction : array [0..3] of glFloat = (1.0, 1.0, 1.0, 1.0); // Цвет тумана. FogColor: array [0..3] of GLfloat = (0, 1.0, 0, 1.0); Var. FogMode: GLint; Begin. // Инициализация контекста воспроизведения OpenGL. DC := GetDC(Wnd); // Получить контекст устройства для окна. SetDCPixelFormat(DC); // Установить формата пикселов. RC := wglCreateContext(DC); // создать новый контекст воспроизведения. WglMakeCurrent(DC,RC); // Установить его текущим. // Свойства материала для режима glEnable(GL_COLOR_MATERIAL). GlMaterialfv(GL_FRONT, GL_AMBIENT, @mat1_amb); GlMaterialfv(GL_FRONT, GL_DIFFUSE, @mat1_dif); GlMaterialfv(GL_FRONT, GL_SPECULAR, @mat1_spec); GlMaterialf (GL_FRONT, GL_SHININESS,mat1_shininess); // Свойства источника света GL_LIGHT1 для режима glEnable(GL_LIGHTING). // Стандартный источник одна команда: glEnable(GL_LIGHT0); GlLightfv(GL_LIGHT1, GL_POSITION,@light_pos); GlLightfv(GL_LIGHT1, GL_AMBIENT, @light_amb); // направленность. GlLightfv(GL_LIGHT1, GL_DIFFUSE, @light_dif); // рассеивание. GlLightfv(GL_LIGHT1, GL_SPECULAR, @light_spec); GlLightfv(GL_LIGHT1, GL_SPOT_DIRECTION, @light_spot_direction); // разрешить источник света GL_LIGHT1. GlEnable(GL_LIGHT1); // Свойства тумана для режима glEnable(GL_FOG). FogMode := GL_EXP; // GL_EXP2, GL_LINEAR. GlFogi(GL_FOG_MODE, fogMode); // установить режим. GlFogfv(GL_FOG_COLOR, @fogColor); // цвет тумана. GlFogf(GL_FOG_DENSITY, 0.002); // плотность - 0.2% GlHint(GL_FOG_HINT, GL_DONT_CARE); // GL_NICEST, GL_FASTEST. GlClearColor(0.0, 0.0, 0.2, 1.0); // Установить цвет фона - синий. GlClearDepth(1.0); // Очистить буфер глубины. GlDepthFunc(GL_LESS); // Тип теста глубины. GlShadeModel(GL_SMOOTH); // плавное цветовое сглаживание. // glEnable(..) - включить режим, glDisable(..) - отключить. GlEnable(GL_LIGHTING); // разрешить осещенность. //glEnable(GL_FOG); // разрешить тумана. GlEnable(GL_DEPTH_TEST); // разрешить тест глубины, с использованием. // функции определенной в glDepthFunc. GlEnable(GL_NORMALIZE); // разрешить нормали (различение передней. // и задней сторон плоских объектов). GlEnable(GL_COLOR_MATERIAL); // разрешить использование материалов на объектах. GlEnable(GL_TEXTURE_2D); // разрешить наложение текстур. //glEnable(GL_BLEND); // разрешить смешивание (напр. прозрачность). // не совместимо с glEnable(GL_DEPTH_TEST). GlLoadTexture('1.bmp', Texture); // загружаем текстуру. End; {------------------------------------------------------------------} { Завершение работы с OpenGL }. {------------------------------------------------------------------} Procedure glKill(Wnd: hWND); Begin. WglMakeCurrent(DC, 0); WglDeleteContext(RC); ReleaseDC(Wnd, DC); End; {------------------------------------------------------------------} { Создание объектов под отрисовку }. {------------------------------------------------------------------} Procedure glDraw(); Var. Obj: GLUquadricObj; Begin. // очистка Экрана и буфера глубины. GlClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); GlMatrixMode(GL_MODELVIEW); // Переключаемся на видовую матрицу. GlLoadIdentity; // Сбрасываем все преобразования. // Пример рисования разноцветного треугольника. GlBegin(GL_POLYGON); GlColor(0.0, 0.5, 0.0, 0.0); // Цвет 1-ой вершины. GlVertex3F(-50, -sqrt(3)*50, 0); // 1-я вершина. GlColor(0.5, 0.0, 0.0, 0.0); // Цвет 2-ой вершины. GlVertex3F(-100, -sqrt(3)*100, 0); // 2-я вершина. GlColor(0.0, 0.0, 0.5, 0.0); // Цвет 3-ей вершины. GlVertex3F(-125, -sqrt(3)*100, 0); // 3-я вершина. GlEnd; // Следующая фигура будет нарисована повернутой. // Поворачиваем сферу так, чтобы северный полюс на текстуре. // смотрел в нужную сторону. GlRotate(-90, 0.0, 1.0, 0.0); GlRotate(60, 1.0, 0.0, 0.0); // здесь поворот сферы вокруг оси. GlRotate(-Angle, 0.0, 0.0, 1.0); // Пример рисования сферы. GlColor(1.0, 1.0, 1.0, 0.5); // установить цвет объекта. GlBlendFunc(GL_SRC_ALPHA,GL_ONE); // Функция смешивания для непрозрачности, // базирующаяся на значении альфы. // Отрабатывает только при glEnable(GL_BLEND). GlBindTexture(GL_TEXTURE_2D, Texture); // установить текущую текстуру Texture. Obj:=gluNewQuadric; GluQuadricTexture(Obj, GL_TRUE); // разрешить наложить текущую текстуру на. // создаваемый объект. GluSphere(Obj, 100, 25, 25); // создать сферу R = 100, детализация - 25х25. GluDeleteQuadric(Obj); // Освобождаем память. Angle := (Angle + 5) mod 360; // Выводим на экран подготовленную сцену. SwapBuffers(DC); End; {------------------------------------------------------------------} { Выбор приемлемого формата точки для данного DC }. {------------------------------------------------------------------} Procedure SetDCPixelFormat(DC: hDC); Var. Pfd: TPixelFormatDescriptor; NPixelFormat: Integer; Begin. FillChar(pfd, SizeOf(pfd), 0); With pfd do. Begin. NSize := sizeof(pfd); NVersion := 1; DwFlags := PFD_DRAW_TO_WINDOW or. PFD_SUPPORT_OPENGL or. PFD_DOUBLEBUFFER; IPixelType := PFD_TYPE_RGBA; CColorBits := 16; CDepthBits := 64; ILayerType := PFD_MAIN_PLANE; End; NPixelFormat := ChoosePixelFormat(DC, @pfd); SetPixelFormat(DC, nPixelFormat, @pfd); End; {------------------------------------------------------------------} { Загрузка 8 или 24-битного bmp-файла текстуры }. {------------------------------------------------------------------} Procedure glLoadTexture(Filename: String; var Texture: GLuint); Type BitmapHeader= Record. FH: BitmapFileHeader; IH: BitmapInfoHeader; End; Var. ColorTable: array of TRGBQuad; Data: array of Byte; RGBData: array of TRGBTriple; Bmp: BitmapHeader; Tmp, i, L: Cardinal; F: hFile; Begin. F := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0); If F = INVALID_HANDLE_VALUE then. Begin. MessageBox(0,PChar('File '+ FileName + ' not found'), 'glLoadTexture',0); Exit; End; ReadFile(F, Bmp, sizeof(BitmapHeader),tmp, nil ); L := Bmp.IH.biWidth * Bmp.IH.biHeight; SetLength(RGBData, L); Case Bmp.IH.biBitCount of. 8: Begin. SetLength(ColorTable, round(exp(Bmp.IH.biBitCount*Ln(2)))); ReadFile(F, ColorTable[0], SizeOf(TRGBQuad) * round(exp(Bmp.IH.biBitCount*Ln(2))), tmp, nil); SetLength(Data, L); ReadFile(F, Data[0], SizeOf(Byte) * L, tmp, nil); For i := 0 to L - 1 do. Begin. RGBData[L - i - 1].rgbtRed := ColorTable[Data[i]].rgbBlue; RGBData[L - i - 1].rgbtGreen := ColorTable[Data[i]].rgbGreen; RGBData[L - i - 1].rgbtBlue := ColorTable[Data[i]].rgbRed; End; End; 24: Begin. SetLength(Data, L * 3); ReadFile(F, Data[0], SizeOf(Byte) * L * 3, tmp, nil); For i := 0 to L - 1 do. Begin. RGBData[L - i - 1].rgbtRed := Data[3 * i]; RGBData[L - i - 1].rgbtGreen := Data[3 * i + 1]; RGBData[L - i - 1].rgbtBlue := Data[3 * i + 2]; End; End; Else MessageBox(0, 'Format not support', 'glLoadTexture', 0); End; { end case}. CloseHandle(F); // Далее код из BMP.pas от Jan Horn. GlGenTextures(1, Texture); GlBindTexture(GL_TEXTURE_2D, Texture); GlTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE); {Texture blends with object background}. // glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL); {Texture does NOT blend with object background}. { Select a filtering type. BiLinear filtering produces very good results with little performance impact. GL_NEAREST - Basic texture (grainy looking texture). GL_LINEAR - BiLinear filtering. GL_LINEAR_MIPMAP_NEAREST - Basic mipmapped texture. GL_LINEAR_MIPMAP_LINEAR - BiLinear Mipmapped texture. } GlTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); { only first two can be used }. GlTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); { all of the above can be used }. GluBuild2DMipmaps(GL_TEXTURE_2D, 3, Bmp.IH.biWidth, Bmp.IH.biHeight, GL_RGB, GL_UNSIGNED_BYTE, RGBData); // Use when not wanting mipmaps to be built by openGL. // glTexImage2D(GL_TEXTURE_2D, 0, 3, Bmp.IH.biWidth, Bmp.IH.biHeight, 0, GL_RGB, GL_UNSIGNED_BYTE, RGBData); End; End.
07 Собранный пример VCL ======================= На форме таймер, в проект включен MyOpenGL.pas. В той же папке лежит 8 или 24-битный bmp-фаил.
Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, MyOpenGL; Type. TForm1 = class(TForm). Timer1: TTimer; Procedure FormDestroy(Sender: TObject); Procedure FormResize(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.FormDestroy(Sender: TObject); Begin. GlKill(Form1.Handle); End; Procedure TForm1.FormResize(Sender: TObject); Begin. GlOnResize(Form1.ClientWidth,Form1.ClientHeight); End; Procedure TForm1.Timer1Timer(Sender: TObject); Begin. GlDraw(); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. GlInit(Form1.Handle); GlOnResize(Form1.ClientWidth,Form1.ClientHeight); End; End.
08 Собранный пример WinApi ========================== В той же папке лежит 8 или 24-битный bmp-файл.
Code: Program a; Uses. Windows, Messages, MyOpenGL in 'MyOpenGL.pas'; Var. MainWnd: hWND; Function WindowProc(Wnd: HWND; Msg: Integer; wParam: wParam; lParam:lParam):lResult;stdcall; Begin. Case Msg of. WM_DESTROY: Begin. GlKill(MainWnd); Postquitmessage(0); Result := 0; Exit; End; WM_TIMER: Begin. GlDraw(); // Рисуем сцену. Result := 0; End; WM_SIZE: Begin. // В lParam содержатся размеры клиентской области ;-). GlOnResize(loWord(lParam), hiWord(lParam)); Result := 0; End; Else. Result := DefWindowProc(Wnd, Msg, wParam, lParam); End; End; Var. Mesg: TMsg; Wc : TWndClassEx; Begin. Wc.cbSize := sizeof(wc); Wc.style := CS_HREDRAW or CS_VREDRAW; Wc.lpfnWndProc := @WindowProc; Wc.cbClsExtra := 0; Wc.cbWndExtra := 0; Wc.hInstance := hInstance; Wc.hIcon := LoadIcon(0, IDI_WINLOGO); Wc.hCursor := LoadCursor(0, IDC_ARROW); Wc.hbrBackground := COLOR_BTNFACE+2; Wc.lpszMenuName := nil; Wc.lpszClassName := 'aWnd'; RegisterClassEx(wc); // Создаем окно 400хЧ00. MainWnd := CreateWindowEx (0, 'aWnd', 'MyOpenGL', WS_OVERLAPPEDWINDOW or WS_VISIBLE, 100, 100, 400, 400, 0, 0, hInstance, nil); // Создаем контекст воспроизведения OpenGL и его параметры. GlInit(MainWnd); // Задаем матрицы OpenGL для размера окна 400хЧ00. GlOnResize(400, 400); // Устанавливаем таймер 10мс для перерисовки сцены. SetTimer(MainWnd, 1, 10, nil); While GetMessage(Mesg, 0, 0, 0) do. Begin. TranslateMessage(Mesg); DispatchMessage(Mesg); End; End.
************************************* ************ Часть II *************** ************************************* В этой части будут только указаны исправления кода MyOpenGL.pas, которые надеюсь без труда сделаете сами, или просто общие сведения. 09 Списки ========= "Список - это некоторый набор команд OpenGL, который можно создать один раз, например, перед началом работы программы, а потом им пользоваться вызывая его. По логике он аналогичен процедуре (или функции, как хотите). Отличие его от процедуры в том, что при формировании списка библиотека сохраняет его в каком-то своем, оптимизированном формате и вызовы списка приводят к значительно меньшим вычислительным затратам чем вызов функции, делающей тоже самое. Особенно хорошо это заметно на картах, где операции со списками реализованы аппаратно." (Взято с http://firststeps.ru/mfc/opengl/r.php?41) Где-то до использования MyOpenGL.glDraw (напр. в MyOpenGL.glInit).
Code: // Глобальная переменная для MyOpenGL.pas. Var. MyList: GLuint; ... // указываем, что в списке два набора команд. MyList := glGenLists(2); // Создаем первый набор команд. // Флаг GL_COMPILE указывает что его надо только создать. // Использование GL_COMPILE_AND_EXECUTE сразу же еще и выполнило бы этот набор. // В первом наборе будем рисовать треугольник. GlNewList(MyList, GL_COMPILE); GlBegin(GL_POLYGON); GlVertex3F(0.0, 0.0, 0.0); GlVertex3F(100.0, 0.0, 0.0); GlVertex3F(50.0, sqrt(3)*50, 0.0); GlEnd; // Указываем что завершили создание набора команд. GlEndList(); // Создаем второй набор команд. // Во втором наборе к матрице GL_MODELVIEW будет добавляться параллельный. // перенос на 50 по оси OX и на 1 по оси OZ (это чтобы поверх остального). // Поставить переменные значения в перенос нельзя, так как это будет уже. // другая матрица. Хотя может я и ошибаюсь. GlNewList(MyList + 1, GL_COMPILE); GlTranslatef(50, sqrt(3) * 12.5, 1); // Указываем что завершили создание набора команд. GlEndList();
MyOpenGL.glDraw можно переписать так. В итоге получим, что рисуется одна неподвижная фигура (зеленая), а другая вращающаяся, выполненая как и первая, и перенесенная в центр первой и на уровень выше первой (красная).
Code: Procedure glDraw(); Begin. // очистка Экрана и буфера глубины. GlClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); // Сбрасываем GL_MODELVIEW до единичной. GlLoadIdentity(); // Устанавливаем зеленый цвет для фигур. GlColor(0.0, 1.0, 0.0, 1); // Создаем фигуру, используя набор команд MyList. GlCallList(MyList); // Добавляем значение к углу поворота. Angle := (Angle + 5) mod 360; // Вызываем второй набор команд, который хранится по MyList + 1. // В результате к GL_MODELVIEW добавляется перенос. GlCallList(MyList + 1); // Добавим к GL_MODELVIEW-матрице еще и поворот на угол Angle. GlRotate(Angle, 0.0, 0.0, 1.0); // Устанавливаем красный цвет для фигур. GlColor(1.0, 0.0, 0.0, 1); // Создаем фигуру, используя набор команд MyList. // Поскольку GL_MODELVIEW-матрица у нее другая, то и распалагается. // она уже иначе, чем первая фигура. GlCallList(MyList); // Выводим на экран подготовленную сцену. SwapBuffers(DC); End;
Ну и в MyOpenGL.glKill стоит добавить
Code: GlDeleteLists(MyList, 2); // удаляем все элементы списка :-).
Примечание: устоявшееся понятие "список отображениия" - список, в котором все наборы команд - это рисование фигуры (шаблон). См. Народный учебник, Глава 12. 10 Собранный пример WinAPI без таймера для отрисовки ==================================================== Взято у Jan Horn (http://www.sulaco.co.za, http://home.global.co.za/~jhorn) Как обычно, в папке проекта есть MYOpenGL.pas и 1.bmp :-) Идеи таковы: * пока приложение не обработает всю свою очередь сообщений, перерисовка выполняться не будет; * Если нажали кнопку, то в массиве "Статус кнопок" для соответсвующего элемента выстанавливается значение True, которое скинется после обработки этого нажатия в ProcessKey. Такая схема позволяет запретить накопление нажатий.
Code: Program a; Uses. Windows, Messages, MyOpenGL in 'MyOpenGL.pas'; Var. MainWnd: hWND; FPSCount: Integer; // Число FPS. Keys : array [0..255] of Boolean; // Статусы кнопок. Function IntToStr(Num: Integer) : String; Begin. Str(Num, result); End; // Обработка кнопок. Procedure ProcessKeys; Begin. If (keys[VK_UP]) then. Begin. // Что-то делаем. //... // Сбрасываем нажатие этой кнопки. Keys[VK_UP] := False; End; If Keys[Ord('H')] then. Begin. // Что-то делаем. //... // Сбрасываем нажатие этой кнопки. Keys[Ord('H')] := FALSE; End; End; Function WindowProc(Wnd: HWND; Msg: Integer; wParam: wParam; lParam:lParam):lResult;stdcall; Begin. Case Msg of. WM_DESTROY: Begin. GlKill(MainWnd); Postquitmessage(0); Result := 0; Exit; End; WM_KEYDOWN: Begin. Keys[wParam] := True; Result := 0; End; WM_KEYUP: Begin. Keys[wParam] := False; Result := 0; End; WM_TIMER: Begin. FPSCount := Round(FPSCount * 1000/{FPS-интервал - у нас 1с}1000); SetWindowText(MainWnd, PChar('FPS: ' + IntToStr(FPSCount))); FPSCount := 0; End; WM_SIZE: Begin. GlOnResize(loWord(lParam), hiWord(lParam)); Result := 0; End; Else. Result := DefWindowProc(Wnd, Msg, wParam, lParam); End; End; Var. Mesg: TMsg; Wc : TWndClassEx; Finished: Boolean = False; // Флаг завершения работы OpenGL. Begin. Wc.cbSize := sizeof(wc); Wc.style := CS_HREDRAW or CS_VREDRAW; Wc.lpfnWndProc := @WindowProc; Wc.cbClsExtra := 0; Wc.cbWndExtra := 0; Wc.hInstance := hInstance; Wc.hIcon := LoadIcon(0, IDI_WINLOGO); Wc.hCursor := LoadCursor(0, IDC_ARROW); Wc.hbrBackground := COLOR_BTNFACE + 2; Wc.lpszMenuName := nil; Wc.lpszClassName := 'aWnd'; RegisterClassEx(wc); // Создаем окно 400хЧ00. MainWnd := CreateWindowEx (0, 'aWnd', 'MyOpenGL', WS_OVERLAPPEDWINDOW or WS_VISIBLE, 100, 100, 400, 400, 0, 0, hInstance, nil); // Создаем контекст воспроизведения OpenGL и его параметры. GlInit(MainWnd); // Задаем матрицы OpenGL для размера окна 400хЧ00. GlOnResize(400, 400); // Устанавливаем таймер на 1с для отображения FPS в заголовке окна. SetTimer(MainWnd, 1, 1000, nil); While not finished do. Begin. // Если очередь сообщений для окна пуста, то проводим. // расчет и отрисовку сцены, иначе обрабатываем. // очередь сообщений. If (PeekMessage(Mesg, 0, 0, 0, PM_REMOVE)) then. Begin. // Если было получено WM_QUIT, то выход. If (Mesg.message = WM_QUIT) then. Finished := True. Else. Begin. TranslateMessage(Mesg); DispatchMessage(Mesg); End; End. Else. Begin. // Увеличиваем счетчик отрисованных кадров. Inc(FPSCount); // Рисуем-с кадр. GlDraw(); // Если была до этого нажата ESC, то сразу выходим. If (keys[VK_ESCAPE]) then. Finished := True. Else. ProcessKeys; End; End; End.
11 Разное ========= а. Получение текста последней ошибки OpenGL.
MessageBox(0, gluErrorString(glGetError), 'OpenGL error', MB_OK);
б. Восстановление состояния режима Лампа GL_LIGHT0 будет включена или выключена в зависимости от ее состоянием перед началом блока
GlPushAttrib(GL_LIGHT0);
...
GlEnable(GL_LIGH0);
...
GlPopAttrib();
12 Вывод текста в OpenGL ======================== Код получен объединением кода Jan Horn, NeHe (уроки 13 и 14) и DRKB Работа с графикой и мультимедиа > DerectX, OpenGL > OpenGL: Каким обpазом выбиpать pазмеp шpифта. Итак, можем выводить текст как растровое изображение и как векторное (буквы это 3D объекты). Идея такова, что для алфавита подготавливается список (см 09), а при вводе текст разбивается на буквы и потом последовательно для каждой буквы печатаемой строки выполняется соответствующий набор команд из списка. Ниже код, который реализует как растровый, так и как векторный вывод. (необходимо лишь закоментировать указанные строки).
Code: Var. CharList: GLuint; // Вот этот список. Gmf: array [0..255] of GLYPHMETRICSFLOAT; // массив требуется для векторного. ... {----------------------------------------------------------------} { Создание списка букв }. {----------------------------------------------------------------} Procedure glBuildFont; Var. Font: hFont; Begin. // Список для 256 букв алфавита. CharList := glGenLists(256); // Создаем шрифт, подробнее см. SDK. Font := CreateFont(-28, 0, 0, 0, FW_BOLD, 0, 0, 0, RUSSIAN_CHARSET, OUT_TT_PRECIS, CLIP_DEFAULT_PRECIS, ANTIALIASED_QUALITY, FF_DONTCARE or DEFAULT_PITCH, 'Comic Sans MS'); // Устанавливаем шрифт для DC. SelectObject(DC, Font); // Создаем команды списка. // Выбираем один из двух вариантов. // Если используем wglUseFontBitmaps то - это растровое изображение. If not wglUseFontBitmaps(DC, 0, 256, CharList) then. Или. // Если используем wglUseFontOutlines то - это векторное изображение. If not wglUseFontOutlines(DC, 0, 255, CharList, 0, 0.2, WGL_FONT_POLYGONS, @gmf) then. MessageBox(0, 'Font not create', 'glBuildFont', MB_OK); // Удаляем шрифт, так как соответствующий список уже создан. DeleteObject(Font); End; {----------------------------------------------------------------} { Вывод строки на экран }. {----------------------------------------------------------------} Procedure glPrint(X, Y: Integer; text: String); Begin. // Расчитывается позиция на экране. Требуется только для растрового. // вывода. То есть при векторном выводе X и Y gLPrint игнорируются, // поэтому перед выводом надо будет воспользоваться glTranslatef. GlRasterPos2i(X, Y); GlPushAttrib(GL_LIST_BIT); // Указыывем, что первая буква алфавита рисуется 1-ым набором команд. GlListBase(1); // Выводим текст. GlCallLists(length(text), GL_UNSIGNED_BYTE, PChar(text)); GlPopAttrib(); End; ... // Где-то перед использованием вывода текста, напр. в MyOpenGL.glInit. // после создания контеста воспроизведения RC. GlBuildFont; ... // Когда работа с текстом будет уже не нужна, то очистим список. // Напр. в MyOpenGL.glKill перед освобождением RC. GlDeleteLists(CharList, 256);
Добавление теста на сцену немного различается. Далее добавляемый код в процедуру построения сцены (напр. в MyOpenGL.glDraw). Для растрового текста
Code: // Устанавливаем цвет букв. GlColor3f(1.0, 0.0, 1.0); // Добавляем текст на сцену. GlPrint(-150, 0, 'Даст ист фантастиш');
Вывод векторного шрифта несколько сложнее, поскольку команды списка создают 3D объекты с определенными размерами (все буквы маленького размераа типа 0.01) (для растровых шрифтов велична букв определяется только первым параметром функции CreateFont в glBuildFont) и поэтому, если у матрица проекций работает не с такими размерами (у меня она работает с размерами как напр. 100), то надо увеличить текст glScale. Так же надо подобрать режимы, чтобы текст смотрелся по-настоящему 3D.
// Подбираем нужный режим
GlEnable(GL_LIGHT0); // Включаем стандартную лампу
GlDisable(GL_LIGHT1); // Отключаем пользовательскую лампу
GlDisable(GL_NORMALIZE); // Отключаем режим нормалей
GlLoadIdentity; // Загружаем в GL_MODELVIEW единичную матрицу
GlTranslatef(-150, 0.0, 0.0); // Добавим перенос от центра
GlScale(100, 100, 1.0); // Растягиваем текст на 100 по ОХ и OY.
GlRotate(45, 1.0, 1.0, 0.0); // Добавим поворот
GlColor(1.0, 0.0, 1.0); // Установим цвет букв
GlPrint(0, 0, 'Даст ист фантастиш'); // Добавим текст на сцену
// Возвращаем все как было
GlDisable(GL_LIGHT0); // Выключаем стандартную лампу
GlEnable(GL_NORMALIZE); // Включаем режим нормалей
GlEnable(GL_LIGHT1); // Включаем пользовательскую лампу
13 Компонент для работы с OpenGL ================================ Напр. на http://glscene.org - GL_Scene - версии для Delphi5-7. Умеет много чего, в частности импорт 3DS файлов. 14 Загрузка объектов под отрисовку из файла =========================================== Почти всегда хочется, чтобы в функции создании сцены (у меня это MyOpenGL.glDraw) объекты под отрисовку загружались с файла. Обычно реализуют свой формат хранения фигур и функции для работы с ним. Я ленивый, потому предлагаю свой способ - хранить не объекты, а набор gl-комманд ему соответствующий, который будет загружаться в список. Например рассмотрим такой фаил.
2.
GlNewList.
GlBegin 4.
GlVertex3f 0 0 0.
GlVertex3f 100,4 0 0.
GlVertex3f 50 100 0.
GlEnd.
GlEndList.
GlNewList.
GlRotate 10 0 1 0.
GlEndList.
2 - это то что в списке 2 набора команд. Соответвенно в самой программе это будет использоваться так (на примере MyOpenGL) Примечания: 1. дробная часть указывается через запятую! 2. Для glBegin значения констант смотреть в OpenGL.pas.
Code: Uses MyGLU; ... Var. List: GLuint; Count: Integer; ... // Где-то до использования создания сцены, напр. в MyOpenGL.glInit. Count := gluLoadList('1.gls', List); // моя функция загрузки скрипта из файла из MyGLU.pas. ... // Где-то в функции создания сцены, напр. в MyOpenGL.glDraw. For i := 0 to Count - 1 do. Begin. GlCallList(List + i); // Вызываем i-ый набор команд; нумерация с нулевого. End;
По-моему замечательная идея ;-) Возможно у нее уже есть реализация. А теперь черновой код MyGLU.pas (поддерживаются не все функции gl, да и контроль ошибок минимальный). Дописывать я его уже наверно не буду; если вам понравилась идея, то доработать его думаю труда не составит - все прозрачно.
Code: Unit MyGLU; Interface. Uses windows, OpenGL, SysUtils; // Функция создает список, используя команды из текстового файла. // Возвращаемое значение - число элементов созданного списка. Function gluLoadList(FileName: String; var List: GLuint): Integer; Implementation. Var. Param: array [1..10] of Extended; // Получение из входной строки S подслов, которые конвертируется в Float. // и помещаются в соответствующий Param[i]. S начинает обрабатываться. // с S[Pos]. Function GetParam(S: String; Pos: Integer): Integer; Var. I, j: Integer; Value: String; Begin. For i := 1 to 10 do Param[i] := 0; J := 1; Value := ''; For i := Pos + 1 to Length(S) do. If (S[i] = ' ') then. Begin. Param[j] := StrToFloat(Value); If j = 10 then. Begin. Result := 10; MessageBox(0, PChar('Too many params!'), 'GetParam', MB_OK); Exit; End. Else j := j + 1; Value := ''; End. Else Value := Value + S[i]; If Value <> '' then Param[j] := StrToFloat(Value); Result := j; End; Function gluLoadList(FileName: String; var List: GLuint): Integer; Var. F: TextFile; S, Command: String; Count, CurrList, i: Integer; Obj: GLUquadricObj; Begin. If not FileExists(FileName) then. Begin. MessageBox(0, PChar('File '+FileName + ' not found'), 'glLoadList', MB_OK); End; AssignFile(F, FileName); Reset(F); Readln(F, S); Count := StrToInt(S); CurrList := 0; // сдвиг; иначе номер набора команд. List := glGenLists(Count); Obj := gluNewQuadric; // читаем из файла, если видим знакомую команду, то выполняем. While not EOF(F) do. Begin. Command := ''; Readln(F, S); For i := 1 to Length(S) do. If S[i] = ' ' then break. Else Command := Command + S[i]; GetParam(S, i); Command := UpperCase(Command); If Command = 'GLNEWLIST' then. GlNewList(List + CurrList, GL_COMPILE); If Command = 'GLENDLIST' then. Begin. GlEndList; CurrList := CurrList + 1; End; If Command = 'GLBEGIN' then. GlBegin(round(Param[1])); If Command = 'GLEND' then. GlEnd; If Command = 'GLROTATE' then. GlRotate(Param[1], Param[2], Param[3], Param[4]); If Command = 'GLSCALE' then. GlScale(Param[1], Param[2], Param[3]); If Command = 'GLTRANSLATEF' then. GlTranslatef(Param[1], Param[2], Param[3]); If Command = 'GLVERTEX3F' then. GlVertex3f(Param[1], Param[2], Param[3]); If Command = 'GLCOLOR' then. GlColor(Param[1], Param[2], Param[3], Param[4]); If Command = 'GLLOADIDENTITY' then. GlLoadIdentity; If Command = 'GLPUSHMATRIX' then. GlPushMatrix; If Command = 'GLPOPMATRIX' then. GlPopMatrix; If Command = 'GLUSPHERE' then. GluSphere(Obj, Param[1], round(Param[2]), round(Param[3])); If Command = 'GLUCYLINDER' then. GluCylinder(Obj, Param[1], Param[2], Param[3], round(Param[4]), round(Param[5])); If Command = 'GLUDISK' then. GluDisk(Obj, Param[1], Param[2], round(Param[3]), round(Param[4])); End; GlEndList; GluDeleteQuadric(Obj); CloseFile(F); Result := Count; End; End.
15 Bmp - формат =============== Вообщем то к OpenGL это никакого отношения не имеет, но загрузку текстур все-таки зачастую приходится производить из него, так что полезно представлять что это такое. Описание самое простейшее, многое выкинуто, но для общего понимания и загрузки текстур из bmp-файлов - этого будет достаточно. В начале каждого bmp-файла идет служебная информация - общая информация о файле TBitmapFileHeader и потом общая информация о bmp-изображении - TBitmapInfoHeader. Определения типов из windows.pas (комментарии мои).
Code: Type. TagBITMAPFILEHEADER = packed record. BfType: Word; // тип файла - для Bmp = BM ~ $42$4D. BfSize: DWORD; // размер файла в байтах. BfReserved1: Word; // зарезервировано. BfReserved2: Word; // зарезервировано. BfOffBits: DWORD; // номер байта; со следующего начнется "изображение". End; TBitmapFileHeader = tagBITMAPFILEHEADER; TagBITMAPINFOHEADER = packed record. BiSize: DWORD; // размер структуры BitmapInfoHeader, байт. BiWidth: Longint; // ширина изображения. BiHeight: Longint; // высота изображения; отрицательна, если изображение. // надо перевернуть. BiPlanes: Word; // число плоскостей изображения, всегда 1. BiBitCount: Word; // число бит на точку; ОЧЕНЬ ВАЖНЫЙ ПАРАМЕТР. BiCompression: DWORD; // Флаг компрессии - обычно BI_RGB (=0). BiSizeImage: DWORD; // Размер изображения в байтах. BiXPelsPerMeter: Longint; // разрешение точек на метр по OX И по OY. BiYPelsPerMeter: Longint; BiClrUsed: DWORD; // используемое количество цветов. BiClrImportant: DWORD; // Обычно = biClrUsed. End; TBitmapInfoHeader = tagBITMAPINFOHEADER; End;
Код поясняющий это
Code: // Для простоты определим тип, состоящий из двух нужных нам. Type. TBitmapHeader = record. FH: TBitmapFileHeader; IH: TBitmapInfoHeader; End; ... Var. Bmp: TBitmapHeader; Tmp: Cardinal; F: hFile; ... // Для доступа к файлу, определяемого FileName, я использую WinAPI-функцию. // Примерный смысл параметров, думаю, ясен. F := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0); // Читаем данные из файла F, данные помещаются в Bmp, количество байт которых. // хотим прочитать - это третий параметр, количество прочитанных байт будет. // помещено в tmp. ReadFile(F, Bmp, sizeof(TBitmapHeader), tmp, nil); ... // // Ширина изображения для примера. MessageBox(0, PChar(IntToStr(Bmp.IH.biWidth)), 'Width', MB_OK); ... // Закрываем файл. CloseHandle(F);
После этого заголовка (в байтах это Bmp.FH.bmOffBits) хранится изображение. Следует различать две группы bmp-изображений 1, 4, 8-битные и 16, 24, 32-битные. Для первой группы сначала идет палитра - то есть перечисение цветов в формате Red-Green-Blue-Alpha (TRGBQuad), содержащая biClrUsed-цветов (обычно это равно 2 ^ biBitCount), потом идут точки изображения - каждая точка пишется в соответсвующее количество бит (1, 4, 8) - это просто номер цвета из палитры. Для второй группы палитры нет, а сразу идут точки - для 24 и 32-битных изображений - в формате RGB и RGBA (по байту на составляющую, что и дает соответствующую битность); для 16-битных несколько хитрее, потому опущу описание. При загрузке текстуры передаются - ширина, высота изображения и массив RGB точек. Для 24- и 32- битных bmp файлов - массив получается элементарно. Для 1, 4 и 8- битных необходимо этот массив формировать на основе палитры. Примечания * Точки изображения пробегаются с нижнего левого угла. * Цвета в BMp-файле зранятся в последовательности BGR, потому при загрузке в тестуру надо менять R и B цвета местами. * На самом деле, есть еще такое понятие как байтовое выравнивание в точках, при ширине изображения кратной 4 (для текстур это разумеется верно) об этом можно не беспокоится. Пример загрузки 8- и 24-битных изображений можно посмотреть в MyOpenGL.glLoadTexture.
Взято из http://forum.sources.ru.
Автор: Zoobastik.
©Drkb::03950.
| Opening Access (early binding). |
Before you can use this method, you must have imported the type library (MSAcc8.olb for Access 97).
One way of starting Access is Excelto try the GetActiveObject call, to get a running instance of Access, but put a call to CoApplication.Create in an except clause. But except clauses are slow, and can cause problems within the IDE for people who like Break On Exceptions set to True. The following code removes the need for a try...except clause, by avoiding using OleCheck on GetActiveObject in the case when Access is not running.
Code: Uses Windows, ComObj, ActiveX, Access_TLB; Var. Access: _Application; AppWasRunning: boolean; // tells you if you can close Access when you've finished. Unknown: IUnknown; Result: HResult; Begin. AppWasRunning := False; {$IFDEF VER120} // Delphi 4. Result := GetActiveObject(CLASS_Application_, nil, Unknown); If (Result = MK_E_UNAVAILABLE) then. Access := CoApplication_.Create. {$ELSE} // Delphi 5. Result := GetActiveObject(CLASS_AccessApplication, nil, Unknown); If (Result = MK_E_UNAVAILABLE) then. Access := CoAccessApplication.Create. {$ENDIF}. Else begin. { make sure no other error occurred during GetActiveObject }. OleCheck(Result); OleCheck(Unknown.QueryInterface(_Application, Access)); AppWasRunning := True; End; Access.Visible := True; ...
Opening PowerPoint.
Opening PowerPoint (early binding).
Before you can use this method, you must have imported the type library (MSPpt8.olb for PowerPoint 97).
One way of starting PowerPoint is to try the GetActiveObject call, to get a running instance of PowerPoint, but put a call to CoApplication.Create in an except clause. But except clauses are slow, and can cause problems within the IDE for people who like Break On Exceptions set to True. The following code removes the need for a try...except clause, by avoiding using OleCheck on GetActiveObject in the case when PowerPoint is not running.
Code: Uses Windows, ComObj, ActiveX, OfficePowerPoint_TLB; Var. PowerPoint: _Application; AppWasRunning: boolean; // tells you if you can close PowerPoint when you've finished. Unknown: IUnknown; Result: HResult; Begin. AppWasRunning := False; Result := GetActiveObject(CLASS_Application, nil, Unknown); If (Result = MK_E_UNAVAILABLE) then. PowerPoint := CoApplication.Create. Else begin. { make sure no other error occurred during GetActiveObject }. OleCheck(Result); OleCheck(Unknown.QueryInterface(_Application, PowerPoint)); AppWasRunning := True; End; PowerPoint.Visible := TOleEnum(msoTrue); ...
©Drkb::04463.
Without using the type library.
Automation is so much easier and faster using type libraries (early binding) that you should avoid managing without if at all possible. But if you really can't, here's how to get started:
Code: Var. PowerPoint: Variant; Begin. Try. PowerPoint := GetActiveOleObject('PowerPoint.Application'); Except. PowerPoint := CreateOleObject('PowerPoint.Application'); End; PowerPoint.Visible := True;
©Drkb::04464.
| Open GL in Delphi. Часть 1. Первые полигоны |
Первая программа с использованием OpenGL.
| Open GL in Delphi. Часть 2. Туман |
Мы сегодня будем работать с туманом... Во всех предыдущих примерах использовался туман,
но его действия вы наверное не замечали, но теперь вы это ощутите.
| Open GL in Delphi. Часть 3. Quadric - объекты |
В разделе переменных укажим:
Code: QuadObj : NewQuadricObj;
| Open GL in Delphi. Часть 4. Сглаживание |
Сглаживание позволяет получить более красивую картинку.
По умолчанию сглаживание включено.
За включение/выключение этого самого сглаживания отвечает процедура
GlShadeModel.
Параметры у неё следующие:
GL_SMOOTH - установлено по-умолчанию
GL_FLAT - отключение режима сглаживания
| Open GL in Delphi. Часть 5. GLAux. |
До этого мы писали программы с использованием OpenGL и GLUT.
Но SGI* приготовила программистам ещё одну библиотеку.
GLAUX - библиотека, где есть всё для работы с OpenGL.
(чтение файла растра, наложение текстуры, построение примитивов...). Правда
одно маленькое замечание: в разделе Инструмент вы найдёте
Glaux.dll в архиве RAR (~160kb), но в распакованном виде она
"весит" !1.32 Mb!, и вам придётся "таскать" этот файл вместе
со своей программой. Так же в разделе Инструмент вы найдёте
заголовки Этой библиотеки для DELPHI и для C++. !!!ВНИМАНИЕ!!!
Кто может "конвертнуть" заголовки из С++ в DELPHI, тот сделает
благородное дело для себя и ОСТАЛЬНЫХ! А теперь поговорим про программировании с этой библиотекой.
Откройте новый проект: File -> New -> Application.
Теперь в дириктиву "uses" добавьте "glaux" вот так
(файл GLAUX.pas должен быть у вас):
Code: Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,ExtCtrls, Dialogs, glaux. //Подключаем Glaux.pas.
Далее в процедуре TForm1.draww, после того как переведём
камеру в нужную точку функцией
Oracle иТStогеdРгос.
| Oracle иTStoredProc. |
Недавно я перешел на использование Oracle, и все мои попытки использовать компонент TStoredProc кончаются неудачей. Почему?
Причины неработоспособности компонента TStoredProc могут быть следующими. Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают). И во-вторых, имеется известная проблема, описание которой содержится в разделе Developers support корпоративного сайта Inprise. Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.
Наталия Елманова Компьютер Пресс - CD, 1999, N 8 Copyright N.Elmanova & ComputerPress Magazine.
©Drkb::02717.
| Создать новый Outlook Contact? |
Code: Uses. ComObj, Variants, SysUtils; Type. TContact = record. LastName: string; FirstName : string; Company : string; // ### Further properties. See MSDN. End; //------------------------------------------------------------------------------ {:Add outlook contact. @param ContactFolderPath The contact path. E.g.: '' for default contact folder, 'SubFolder\Sub2\Test' for subfolders. @param Contact The contact informations. @author 19.09.2003 Michael Klemm}. //------------------------------------------------------------------------------ Procedure OutlookAddContact(ContactFolderPath : string; Contact : TContact); Const. OlFolderContacts = $0000000A; Var. Outlook : OleVariant; NameSpace : OleVariant; ContactsRoot : OleVariant; ContactsFolder : OleVariant; OutlookContact : OleVariant; SubFolderName : string; Position : integer; Found : boolean; Counter : integer; TestContactFolder : OleVariant; Begin. // Connect to outlook. Outlook := CreateOleObject('Outlook.Application'); // Get name space. NameSpace := Outlook.GetNameSpace('MAPI'); // Get root contacts folder. ContactsRoot := NameSpace.GetDefaultFolder(olFolderContacts); // Iterate to subfolder. ContactsFolder := ContactsRoot; While ContactFolderPath <> '' do. Begin. // Extract next subfolder. Position := Pos('\', ContactFolderPath); If Position > 0 then. Begin. SubFolderName := Copy(ContactFolderPath, 1, Position - 1); ContactFolderPath := Copy(ContactFolderPath, Position + 1, Length(ContactFolderPath)); End. Else. Begin. SubFolderName := ContactFolderPath; ContactFolderPath := ''; End; If SubFolderName = '' then. Break; // Search subfolder. Found := False; For Counter := 1 to ContactsFolder.Folders.Count do. Begin. TestContactFolder := ContactsRoot.Folders.Item(Counter); If LowerCase(TestContactFolder.Name) = LowerCase(SubFolderName) then. Begin. ContactsFolder := TestContactFolder; Found := True; Break; End; End; // If not found create. If not Found then. ContactsFolder := ContactsFolder.Folders.Add(SubFolderName); End; // Create contact item. OutlookContact := ContactsFolder.Items.Add; // Fill contact information. OutlookContact.FirstName := Contact.FirstName; OutlookContact.LastName := Contact.LastName; OutlookContact.CompanyName := Contact.Company; // ### Further properties. // Save contact. OutlookContact.Save; // Disconnect from outlook. Outlook := Unassigned; End;
| OwnerDraw в компоненте StatusBar. |
Code: 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;
| Packet.pas. |
Code: {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Author: Alexander Vaga. EMail: alexander_vaga@hotmail.com. Creation: May, 2002. Legal issues: Copyright (C) 2002 by Alexander Vaga. Kyiv, Ukraine. This software is provided 'as-is', without any express or. Implied warranty. In no event will the author be held liable. For any damages arising from the use of this software. Permission is granted to anyone to use this software for any. Purpose, including commercial applications, and to alter it. And redistribute it freely. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} Unit Packet; Interface. Uses Types,SysUtils,Math,StdCtrls, Windows,Winsock; Const OL : booLean = false; Function CreatePacket(ChID:byte; var SEQ:word) : PPack; Function PacketNew : PPack; Procedure PacketDelete(p:PPack); Procedure PacketAppend8(p : PPack; i : byte); Procedure PacketAppend16(p : PPack; i : word); Procedure PacketAppend32(p : PPack; i : longint); Procedure SetLengthPacket(p : PPack); Procedure TLVAppendStr(p : PPack; T:word;V:string); Function TLVReadStr(p : PPack; var V:string):word; Procedure TLVAppendWord(p : PPack; T:word;V:word); Procedure TLVAppendDWord(p : PPack; T:word;V:longint); Function TLVReadWord(p : PPack; var V:word):word; Function TLVReadDWord(p : PPack; var V:longint):word; Procedure TLVAppend(p : PPack; T:word;L:word;V:pointer); Procedure SNACAppend(p : PPack; FamilyID,SubTypeID:word); Function PacketRead8(p : PPack): byte; Function PacketRead16(p : PPack): word; Function PacketRead32(p : PPack): longint; Procedure PacketAdvance(p:PPack; i : integer); Procedure PacketAppendB_String(p:PPack; s:string); Procedure PacketAppendString(p:PPack; s:string); Procedure PacketAppendStringFE(p:PPack; s:string); Procedure PacketAppend(p:PPack; what:pointer; len:integer); Procedure PacketRead(p:PPack; Buf:pointer; length:integer); Function PacketReadString(p:PPack):string; Function PacketReadB_String(p:PPack):string; Procedure PacketBegin(p:PPack); Procedure PacketEnd(p:PPack); Procedure PacketGoto(p:PPack; i:integer); Function PacketPos(p:PPack):word; Function Swap(InWord:word):word; Function DSwap(InLong:longint):longint;assembler; Function Dim2Hex(what:pointer;len:integer):string; Function Dim2Str(what:pointer;len:integer):string; Procedure StrToIP(sIP:string; var aIP:IParray); Function IPtoStr(var aIP:IParray):string; Function UTC2LT(year,month,day,hour,min:integer) : TDateTime; Function Now2DateTime : TDateTime; Function SecsSince1970:longint; Function Get_my_IP: string; Function Calc_Pass(PassIN : string):string; Function s(i : longint) : string; Procedure M(Memo:TMemo; s:string); Implementation. Function CreatePacket(ChID:byte; var SEQ:word) : PPack; Var p : PPack; Begin. P := PacketNew; PacketAppend8(p, $2A); PacketAppend8(p, ChID); PacketAppend16(p, swap(SEQ)); inc(SEQ); PacketAppend16(p, 0); // length - must be filled. Result := p; End; Function PacketNew : PPack; Var p : PPack; Begin. New(p); Fillchar(p^,sizeof(Pack),0); P^.cursor :=0; P^.length :=0; PacketNew := p; End; Procedure PacketDelete(p:PPack); Begin. Dispose(p); End; Procedure PacketAdvance(p:PPack; i : integer); Begin. P^.cursor := p^.cursor+i; If p^.cursor > p^.length then. P^.length := p^.cursor; End; Procedure PacketAppend8(p : PPack; i : byte); Begin. PBYTE(@(p^.data[p^.cursor]))^ := i; PacketAdvance(p,sizeof(byte)); End; Procedure PacketAppend16(p : PPack; i : word); Begin. PWORD(@(p^.data[p^.cursor]))^ := i; PacketAdvance(p,sizeof(word)); End; Procedure PacketAppend32(p : PPack; i : longint); Begin. PLONG(@(p^.data[p^.cursor]))^ := i; PacketAdvance(p,sizeof(longint)); End; Procedure SetLengthPacket(p : PPack); Begin. PFLAP_HDR(@(p^.data))^.Len := swap(p^.length-sizeof(FLAP_HDR)); End; Procedure TLVAppendStr(p : PPack; T:word;V:string); Var i : integer; Begin. PacketAppend16(p,swap(T)); // add TYPE. PacketAppend16(p,swap(length(V))); // add LEN. For i:=1 to Length(V) do // add VALUE (variable). PacketAppend8(p,byte(V[i])); End; Function TLVReadStr(p : PPack; var V:string):word; Var i,L : integer; Begin. V:=''; Result := swap(PacketRead16(p)); L := swap(PacketRead16(p)); For i:=1 to L do // add VALUE (variable). V:=V+char(PacketRead8(p)); End; Procedure TLVAppendWord(p : PPack; T:word;V:word); Begin. PacketAppend16(p,swap(T)); // add TYPE. PacketAppend16(p,swap(sizeof(word))); // add LEN. PacketAppend16(p,swap(V)); // add VALUE. End; Function TLVReadWord(p : PPack; var V:word):word; Begin. Result := swap(PacketRead16(p)); // get TYPE. If swap(PacketRead16(p))<>0 then // xxxx LEN (word=2). V := swap(PacketRead16(p)); // get 16-VALUE. End; Procedure TLVAppendDWord(p : PPack; T:word;V:longint); Begin. PacketAppend16(p,swap(T)); // add TYPE. PacketAppend16(p,swap(sizeof(longint))); // add LEN. PacketAppend32(p,dswap(V)); // add VALUE. End; Function TLVReadDWord(p : PPack; var V:longint):word; Begin. Result := swap(PacketRead16(p)); // get TYPE. If swap(PacketRead16(p))<>0 then // xxxx LEN (word=2). V := dswap(PacketRead32(p)); // get 32-VALUE. End; Procedure TLVAppend(p : PPack; T:word;L:word;V:pointer); Begin. PacketAppend16(p,swap(T)); // add TYPE. PacketAppend16(p,swap(L)); // add LEN. PacketAppend(p,V,L); // add VALUE (variable). End; Procedure SNACAppend(p : PPack; FamilyID,SubTypeID:word); Begin. PacketAppend16(p, swap(FamilyID)); PacketAppend16(p, swap(SubTypeID)); PacketAppend16(p, swap($0000)); PacketAppend16(p, Swap(random($FF))); // 00 4D 00 xx. PacketAppend16(p, Swap(SubTypeID)); End; Function PacketRead8(p : PPack): byte; Var val : byte; Begin. Val := PBYTE(@(p^.data[p^.cursor]))^; PacketAdvance(p, sizeof(byte)); Result := val; End; Function PacketRead16(p : PPack): word; Var val : word; Begin. Val := PWORD(@(p^.data[p^.cursor]))^; PacketAdvance(p, sizeof(word)); Result := val; End; Function PacketRead32(p : PPack): longint; Var val : longint; Begin. Val := PLONG(@(p^.data[p^.cursor]))^; PacketAdvance(p, sizeof(longint)); Result := val; End; Procedure PacketAppendB_String(p:PPack; s:string); Var i : integer; Begin. PacketAppend8(p, length(s)); For i:=1 to length(s) do. PacketAppend8(p,byte(s[i])); End; Procedure PacketAppendString(p:PPack; s:string); Var len : word; SStr : string; I : integer; Begin. If s <> '' then begin. SStr := s+#0; Len := length(sStr); PacketAppend16(p, len); For i:=1 to len do begin. PBYTE(@(p^.data[p^.cursor]))^ := byte(sStr[i]); PacketAdvance(p,sizeof(byte)); End; End else begin. PacketAppend16(p, 1); PacketAppend8(p,0); End; End; Function PacketReadString(p:PPack):string; Var length : word; STemp : string; DTemp : TByteArray; Begin. Length := PacketRead16(p); Setlength(sTemp,length-1); PacketRead(p, @dTemp,length); If length = 1 then Result := '' Else begin. Move(dTemp,sTemp[1],length-1); // -1 = without #00. Result := sTemp; End; End; Function PacketReadB_String(p:PPack):string; Var length : byte; DTemp : TByteArray; Begin. Length := PacketRead8(p); Setlength(Result,length); PacketRead(p, @dTemp,length); Move(dTemp,Result[1],length); End; Procedure PacketAppend(p:PPack; what:pointer; len:integer); Begin. Move(what^, PBYTE(@(p^.data[p^.cursor]))^, len); PacketAdvance(p, len); End; Procedure PacketRead(p:PPack; Buf:pointer; length:integer); Begin. Move(p^.data[p^.cursor],Buf^,length); PacketAdvance(p, length); End; Procedure PacketAppendStringFE(p:PPack; s:string); Var len : integer; Begin. If s <> '' then begin. Len := length(s); PacketAppend(p, PChar(s[1]), len); End; PacketAppend8(p, $FE); End; Procedure PacketBegin(p:PPack); Begin. P^.cursor := 0; End; Procedure PacketEnd(p:PPack); Begin. P^.cursor := p^.length; End; Procedure PacketGoto(p:PPack; i:integer); Begin. PacketBegin(p); PacketAdvance(p, i); End; Function PacketPos(p:PPack):word; Begin. Result := p^.cursor; End; Function Swap(InWord:word):word; Begin. Result := (lo(InWord)shl 8)+hi(InWord); End; Function DSwap(InLong:longint):longint;assembler; Asm. MOV EAX,InLong. BSWAP EAX. MOV Result,EAX. End; Function Dim2Hex(what:pointer;len:integer):string; Var i : integer; B : byte; Begin. Result:=''; For i:=0 to len-1 do begin. B:=PByteArray(what)^[i]; Result := Result+inttohex(b,2)+' '; End; End; Function Dim2Str(what:pointer;len:integer):string; Var i : integer; B : byte; Begin. Result:=''; For i:=0 to len-1 do begin. B:=PByteArray(what)^[i]; If b<32 then b:=byte('.'); Result := Result+char(b)+' '; End; End; (****************************************************************) Procedure StrToIP(sIP:string; var aIP:IParray); Var sTemp : string; APos,bPos,cPos : integer; Begin. Longint(aIP) := 0; if sIP = '' then exit; STemp := sIP; APos := pos('.',sTemp); if aPos = 0 then exit; STemp[aPos] := 'a'; BPos := pos('.',sTemp); if bPos = 0 then exit; STemp[bPos] := 'b'; CPos := pos('.',sTemp); if cPos = 0 then exit; STemp[cPos] := 'c'; Try aIP[0] := strtoint(copy(sTemp,1,aPos-1)); except end; Try aIP[1] := strtoint(copy(sTemp,aPos+1,bPos-aPos-1)); except end; Try aIP[2] := strtoint(copy(sTemp,bPos+1,cPos-bPos-1)); except end; Try aIP[3] := strtoint(copy(sTemp,cPos+1,length(sTemp)-cPos)); except end; End; (****************************************************************) Function IPtoStr(var aIP:IParray):string; Begin. IPtoStr := s(aIP[0])+'.'+s(aIP[1])+'.'+s(aIP[2])+'.'+s(aIP[3]); End; (****************************************************************) Function UTC2LT(year,month,day,hour,min:integer) : TDateTime; Var r : longword; Time : TDateTime; TimeStamp : TTimeStamp; TZ_INFO : TIME_ZONE_INFORMATION; Begin. R := GetTimeZoneInformation(_Time_Zone_Information(TZ_INFO)); TimeStamp := DateTimeToTimeStamp(EncodeDate(year,month,day)+EncodeTime(hour,min,0,0)); Time := TimeStampToDateTime(TimeStamp); If r = TIME_ZONE_ID_UNKNOWN then Result := Time. Else Result := Time-((TZ_INFO.Bias+60)/1440); End; (****************************************************************) Function Now2DateTime : TDateTime; Var Time : TDateTime; TimeStamp : TTimeStamp; Year,month,day,hour,min,secs,msecs : word; Begin. DecodeDate(Now, Year, Month, Day); DecodeTime(Now,Hour,Min,Secs,Msecs); TimeStamp := DateTimeToTimeStamp(EncodeDate(year,month,day)+EncodeTime(hour,min,0,0)); Time := TimeStampToDateTime(TimeStamp); Result := Time; End; Function SecsSince1970:longint; Var s1970, sNow : TTimeStamp; Begin. S1970 := DateTimeToTimeStamp(EncodeDate(1970,1,1)); SNow := DateTimeToTimeStamp(Now); SecsSince1970 := Floor(TimeStampToMSecs(sNow)/1000 - TimeStampToMSecs(s1970)/1000); End; Function Get_my_IP: string; Var wVersionRequested : WORD; WsaData : TWSAData; P : PHostEnt; S : array[0..128] of char; P2 : pchar; Begin. Result := '127.0.0.1'; Try {Start up WinSock}. WVersionRequested := MAKEWORD(1, 1); WSAStartup(wVersionRequested, wsaData); Try {Get the computer name}. GetHostName(@s, 128); P := GetHostByName(@s); {Get the IpAddress}. P2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^); Result := p2; Except end; Try {Shut down WinSock} WSACleanup; except end; Except end; OL := Result <> '127.0.0.1'; End; (****************************************************************) Function Calc_Pass(PassIN : string):string; Const pass_tab : array[1..16] of byte = ($F3,$26,$81,$C4,$39,$86,$DB,$92, $71,$A3,$B9,$E6,$53,$7A,$95,$7C); Var i : integer; Begin. Result := ''; For i:=1 to length(PassIN) do. Result := Result+char(byte(PassIN[i]) xor pass_tab[i]); End; Function s(i : longint) : string; Begin. Result := inttostr(i); End; Procedure M(Memo:TMemo; s:string); Begin. Memo.Lines.Add(s); End; End.
| Как нарисовать радугу? |
How do I paint the color spectrum of a rainbow, and if the.
Spectrum is clicked on, how do I calculate what color was.
Clicked on?
The following example demonstrates painting a color spectrum,
And calculating the color of a given point on the spectrum.
Two procedures are presented: PaintRainbow() and.
ColorAtRainbowPoint(). The PaintRainbow() procedure paints a.
Spectrum from red to magenta if the WrapToRed parameter is.
False, or paint red to red if the WrapToRed parameter is true.
The rainbow can progress either in a horizontal or.
Vertical progression. The ColorAtRainbowPoint() function.
Returns a TColorRef containing the color at a given point in.
The rainbow.
Code: Procedure PaintRainbow(Dc : hDc; {Canvas to paint to}. X : integer; {Start position X}. Y : integer; {Start position Y}. Width : integer; {Width of the rainbow}. Height : integer {Height of the rainbow}; BVertical : bool; {Paint verticallty}. WrapToRed : bool); {Wrap spectrum back to red}. Var. I : integer; ColorChunk : integer; OldBrush : hBrush; OldPen : hPen; R : integer; G : integer; B : integer; Chunks : integer; ChunksMinus1 : integer; Pt : TPoint; Begin. OffsetViewportOrgEx(Dc, X, Y, Pt); If WrapToRed = false then. Chunks := 5 else. Chunks := 6; ChunksMinus1 := Chunks - 1; If bVertical = false then. ColorChunk := Width div Chunks else. ColorChunk := Height div Chunks; {Red To Yellow}. R := 255; B := 0; For i := 0 to ColorChunk do begin. G:= (255 div ColorChunk) * i; OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); If bVertical = false then. PatBlt(Dc, i, 0, 1, Height, PatCopy) else. PatBlt(Dc, 0, i, Width, 1, PatCopy); DeleteObject(SelectObject(Dc, OldBrush)); End; {Yellow To Green}. G:=255; B:=0; For i := ColorChunk to (ColorChunk * 2) do begin. R := 255 - (255 div ColorChunk) * (i - ColorChunk); OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); If bVertical = false then. PatBlt(Dc, i, 0, 1, Height, PatCopy) else. PatBlt(Dc, 0, i, Width, 1, PatCopy); DeleteObject(SelectObject(Dc, OldBrush)); End; {Green To Cyan}. R:=0; G:=255; For i:= (ColorChunk * 2) to (ColorChunk * 3) do begin. B := (255 div ColorChunk)*(i - ColorChunk * 2); OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); If bVertical = false then. PatBlt(Dc, i, 0, 1, Height, PatCopy) else. PatBlt(Dc, 0, i, Width, 1, PatCopy); DeleteObject(SelectObject(Dc,OldBrush)); End; {Cyan To Blue}. R := 0; B := 255; For i:= (ColorChunk * 3) to (ColorChunk * 4) do begin. G := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3)); OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); If bVertical = false then. PatBlt(Dc, i, 0, 1, Height, PatCopy) else. PatBlt(Dc, 0, i, Width, 1, PatCopy); DeleteObject(SelectObject(Dc, OldBrush)); End; {Blue To Magenta}. G := 0; B := 255; For i:= (ColorChunk * 4) to (ColorChunk * 5) do begin. R := (255 div ColorChunk) * (i - ColorChunk * 4); OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); If bVertical = false then. PatBlt(Dc, i, 0, 1, Height, PatCopy) else. PatBlt(Dc, 0, i, Width, 1, PatCopy); DeleteObject(SelectObject(Dc, OldBrush)). End; If WrapToRed <> false then begin. {Magenta To Red}. R := 255; G := 0; For i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin. B := 255 -((255 div ColorChunk) * (i - ColorChunk * 5)); OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b))); If bVertical = false then. PatBlt(Dc, i, 0, 1, Height, PatCopy) else. PatBlt(Dc, 0, i, Width, 1, PatCopy); DeleteObject(SelectObject(Dc,OldBrush)); End; End; {Fill Remainder}. If (Width - (ColorChunk * Chunks) - 1 ) > 0 then begin. If WrapToRed <> false then begin. R := 255; G := 0; B := 0; End else begin. R := 255; G := 0; B := 255; End; OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); If bVertical = false then. PatBlt(Dc, ColorChunk * Chunks, 0, Width - (ColorChunk * Chunks), Height, PatCopy) else. PatBlt(Dc, 0, ColorChunk * Chunks, Width, Height - (ColorChunk * Chunks), PatCopy); DeleteObject(SelectObject(Dc,OldBrush)); End; OffsetViewportOrgEx(Dc, Pt.x, Pt.y, Pt); End; Function ColorAtRainbowPoint(ColorPlace : integer; RainbowWidth : integer; WrapToRed : bool) : TColorRef; Var. ColorChunk : integer; ColorChunkIndex : integer; ColorChunkStart : integer; Begin. If ColorPlace = 0 then begin. Result := RGB(255, 0, 0); Exit; End; {WhatChunk}. If WrapToRed <> false then. ColorChunk := RainbowWidth div 6 else. ColorChunk := RainbowWidth div 5; ColorChunkStart := ColorPlace div ColorChunk; ColorChunkIndex := ColorPlace mod ColorChunk; Case ColorChunkStart of. 0 : result := RGB(255, (255 div ColorChunk) * ColorChunkIndex, 0); 1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex, 255, 0); 2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex); 3 : result := RGB(0, 255 - (255 div ColorChunk) * ColorChunkIndex, 255); 4 : result := RGB((255 div ColorChunk) * ColorChunkIndex, 0, 255); 5 : result := RGB(255, 0, 255 - (255 div ColorChunk) * ColorChunkIndex); Else. If WrapToRed <> false then. Result := RGB(255, 0, 0) else. Result := RGB(255, 0, 255); End;{Case}. End; Procedure TForm1.FormPaint(Sender: TObject); Begin. PaintRainbow(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, False, True); End; Procedure TForm1.FormResize(Sender: TObject); Begin. InvalidateRect(Form1.Handle, nil, false); End; Procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Var. Color : TColorRef; Begin. Color := ColorAtRainbowPoint(y, Form1.ClientWidth, True); ShowMessage(IntToStr(GetRValue(Color)) + #32 + IntToStr(GetGValue(Color)) + #32 + IntToStr(GetBValue(Color))); End;
Краткое описание Paradox.
1) Краткое описание - Парадокс - одна из самых старых локальных баз данных. Изначально развивалась фирмой Борланд (до 7й версии включительно), последние 3 версии: 8я, 9я и 10я выпущены фирмой Corel. В настоящее время судьба проекта не известна, но есть основания предполагать, что ни Борланд, ни Corel не имеют далекоидущих планов в отношении этой базы данных, а объёмы её продаж в чистом виде незначительны, впрочем она входит в поставку некоторых версий Corel Office.
2) возможности.
- количество баз данных на сервере - собственно база данных представляет собой каталог на диске который содержит файлы таблиц, индексов, view, форм и т.п. На одном компьютере может быть практически ничем не ограниченное количенство баз данных.
- количество таблиц в базе - неограниченно, но одновременно на одном компьютере не может быть открыто более 127 таблиц и 512 физических файлов.
- размер таблиц - 255 полей, 2000000 записей в таблице (реально меньше, так как лимит блокировок исчерпывается быстрее, реальное количество записей где-то около полумиллиона),
10800 Bytes максимальный размер записи (без Memo/Blob полей), 127 вторичных индексов на таблицу,
256 Mb максимум в Blob поле.
- количество пользователей и количество одновременных подключений - теоретический предел - 300 пользователей, но к этой информации надо относится с известной долей скептицизма, как и любая другая локальная база данных, парадокс в силу своей архитектуры очень плохо работает в многопользовательском режиме и реальное количество работающих одновременных подключений вряд ли может быть больше 10-20.
- наличие View - есть возможность создания View, которые представляют собой обычные текстовые файлы, отвечающие следующим требованиям:
- лежат в каталоге базы данных.
- имеют расширение sql.
- в качестве наполнения имеют обычное выражение SQL.
Кроме того имеется другая разновидность View - файлы QBE (Query By Example) - очень древний, но довольно удобный способ работы с данными - альтернатива SQL, отличается гораздо большей гибкостью, чем SQL, но тем ни менее с развитием серверных баз данных отошедший в прошлое. Итак возможно создание текстового файла с расширением qbe и выражением qbe-запроса внутри, который можно использовать как View.
- наличие SP, языка программирования - сам парадокс поддерживает хранимые процедуры на своём собственном языке, однако я не знаю, можно ли их использовать вне самого парадокса из других програм. Вот пример SP:
Method pushButton (var eventInfo Event).
Var.
Txt String.
MyNum Number.
EndVar.
MyNum = 123.321.
Txt = String(myNum).
MsgInfo("myNum = ", txt).
EndMethod.
Method pushButton (var eventInfo Event).
- наличие триггеров - нет.
- репликация и синхронизация, перенос данных, средства backup - нет, однако, так как каждый объект базы данных является по сути отдельным файлом можно применять любые утилиты для Backup/Restore файлов.
- поддержка кластеров - нет.
- поддержка XML, объектов, внешних процедур. - нет.
- возможность взаимодействия между серверами, включая сервера других типов. - BDE имеет средства для взаимодействия между любыми базами данных, для которых есть BDE драйвера.
Вот пример SQL запроса к 2м базам данных:
Select T1.Field1, T2.Field2 From :Alias1:Table1 T1, :Alias2:Table2 T2.
Where T1.Field3=T2.Field4.
В данном случае не важно в какого типа базы данных под Alias1 и Alias2 - это могут быть базы данных любых разновидностей.
- поддерживаемые типы данных.
Alpha - строка.
Number - 15 знаков, плавающая запятая, плюс-минус 10 в 308 степени.
Money - обычное поле с плавающей запятой, возможно прнименение различных форматов вывода.
Short - целое от -32,767 до +32,767.
Long Integer - от -2147483648 до 2147483647.
BCD - плавающая запятая, повышенная точность, применяется для финансовых рассчётов.
Date - для хранения даты.
Time - для хранения времени.
Timestamp - для хранения даты/времени.
Memo.
Formatted Memo.
Graphic - вариант Blob поля.
OLE - вариант Blob поля.
Logical - True/False.
Autoincrement.
Binary - вариант Blob поля.
Bytes - вариант Blob поля.
- поддерживаемые конструкции SQL - поддерживаются все стандартные конструкции SQL: Select, Update, Insert, Create Table, Create Index, Alter Table, Alter Index, Join и т.д. Нет поддержки всторенных запросов типа: Select * From (Select * ...), нет поддержки использования переменных в запросах, нет возможности использования нескольких SQL statement в одном запросе.
- поддержка транзакций - есть.
- системы репортинга, в том числе для Web - имеется встроенных не очень мощный репортинг, возможно использование других репортинговых систем: Crystal Report, Fast Report, Quick Report, Rave и д.р. Собственного репортинга ориентированного на Web нет.
- наличие собственного агента для выполнения заданий по расписанию - нет.
3) Защита данных, шифрование - очень слабая защита паролем, шифрования нет, защита может предохранить только от неискушённого пользователя, так как присутствуют универсальные пароли, то профессионалом защита снимается за пару минут.
4) простота использования - в целом Парадокс достаточно дружелюбная среда. Администрирование и освоение трудностей не составляет.
- наличие встроенных средств администрирования с GUI интерфейсом - сам Парадокс - программа с довольно продуманным GUI интерфейсом, кроме того с BDE поставляется бесплатная программа Database Desktop, которая практически 90% дублирует функциональность самого Парадокса.
- возможность удалённого и Web администрирования - нет.
- сложность перевода проекта написанного под другую базу данных на рассматриваемую - Следует различать программы написанные именно при помощи самого Парадокса и программы на других языках программирования использующих таблицы формата парадокс.
А)Перевод програм с языка других баз данных на язык Парадокс достаточно трудоёмок и не стоит потраченных усилий.
Б)Если же таблицы формата парадокс используются в третьесторонних программах то перевод с таблиц формата dbf на парадоксовский db обычно почти автоматический.
Перевод с формата db на dbf может быть связан с трудностями, так как db немного более "богатый" формат и могут быть нужны небольшие переделки в коде.
Перевод MS Access в Парадокс и наоборот будет связан с более значительными переделками.
Перевод с серверных баз данных на парадокс практически бессмысленен и подчас очень труден.
Перевод с парадокса на серверные базы данных обычно достаточно лёгок.
Итог: с Парадокса легко перейти на почти любые другие базы данных, обратное зачастую намного сложнее. Наибольшая совместимость с форматом dbf.
- сложность в установке и настройке - установка автоматическая, проблема может быть только одна - на больших винчестерах програма инсталляции может неправильно определять объём свободного места и не ставится (выход - временно занять свободное место оставив свободным только 1 гигабайт на время установки). Настройка не требуется. Практически не конфликтует с другим софтом.
- насколько сложно администрирование сервера - администрирование практически не требуется.
- наличие утилит для автоматизации операций для работы в командной строке - нет.
- наличие собственных утилит для отладки запросов (выполнение SQL, построение плана выполнения кверей, профайлер и т.п.), утилиты для слежения за производительностью сервера. - Сам парадокс, Database Desktop.
5) платформы.
- на которых может работать сервер - MS DOS, MS Windows всех версий после Win 3.1.
- на которых может работать клиент - MS DOS, MS Windows всех версий после Win 3.1.
6) версии продуктов, краткая характеристика отличий.
- наиболее широкораспространена версия 7 - под win32 платформу, последняя версия от Борланд. Последующие версии привносили практически лишь косметические изменения.
7) способы доступа.
- собственные API - есть DBI - API поставляемые с BDE.
ODBC - поддержка только таблиц до 5й версии включительно, для более поздних версий - с ограничениями.
JDBC- есть.
ADO (OLE DB) - фактически работает через драйвер ODBC.
DAO - поддержка только таблиц до 5й версии включительно, для более поздних версий - с ограничениями.
BDE - "родной" и самый быстрый способ доступа.
DBExpress - нет.
Другие: - большое количество сторонних производителей компоеннтов, классов и библиотек для работы с форматами таблиц Парадокс.
Оценка производительности - наиболее быстрый способ доступа - через BDE, на 1-2 порядка превосходит по скорости все остальные способы. Он же обеспечивает и максимальную функциональность.
- языки программирования - Парадокс является очень распространённым форматом для работы с базами данных самых различных языков программирования. Является "родным" для програмных сред от фирмы Борланд: Дельфи, СВиi1dег. Из этих сред работа с таблицами в формате Парадокса очень простая.
8) производительность.
- монопольный доступ - очень высокая, особенно при локальном доступе. Например скорость выполнения Insert квери на локальной таблице при подключении BDE может достигать 2000-3000 кверей в минуту.
- для большого количества одновременных подключений - очень низкая, крайне желательен перевод на бузу данных с серверной архитектурой.
- для больших таблиц - при монопольном доступе весьма большая.
- для больших массивов данных при монопольном доступе - большая.
9) цена - отдельно уже производителями не продаётся, вместе с Corel Office стоит порядка $100. Однако для написания програм которые работают с базами данных Парадокс сам Парадокс не требуется, достаточно иметь набор бесплатных утилит, таких как Database Desktop, тем более Парадокс не нужен для run-time среды таких програм.
10) явные недостатки и преимущества по сравнению с системами такого же класса - парадокс показывает практически такую-же или даже превосходящую производительность чем DBase/FoxPro, однако имеет значительно более слабую собственную среду программирования.
В сравнении с MS Access Парадокс показывает значительно более высокую производительность(примерно на порядок!), но проигрывает в мощности языка программирования и интегрированности с другими продуктами. Кроме того в отличие от MS Access развитие среды Парадокс практически прекращено.
11) предпочтительные проекты для использования.
- с точки зрения количества данных - для проектов манипулирующих не более чем сотней тысяч записей.
- количества пользователей - 1-3 пользователя (одновременных подключений).
- уровня защищённости - не требующие защиты информации.
- цены - для продуктов, которые не должны требовать дополнительных вложений в базы данных.
Распространённости - годится для распространяемых приложений, как весьма компактная и лёгкая в распространении бизнес-модель.
Итог: - оптимально использование баз данных Парадокс для небольших проектов персонального пользования написанных на Дельфи или СБилдере.
12) проекты в которых не рекомендуется использовать - для многопользовательских проектов, там где требуется высокий уровень защитыы данных и большие массивы информации.
13) Известные глюки и проблемы - система очень старая, что характеризует не только значительно устаревший интерфейс и отсутствие новомодных наворотов, но и очень низкое количество глюков. 2 основных глюка:
1. При многопользовательском доступе довольно частое возникновение corrupted table особенно если есть BLOB/Memo поля.
2. При принудительном прерывании транзакции не освобождение ресурсов и как следствие "разбухание" служебных файлов.
14) Краткий обзор основных прилагаемых утилит и средств для обслуживания сервера.
- Database Desktop - полноценная среда для управления любыми базами данных через BDE.
- DataPump - утилита переноса данных из одной базы данных в другую.
- BDE Administrator - программа управления BDE.
15) Краткий обзор наиболее примечательных продуктов третьесторонних производителей для работы с данной базой данных. - огромное количество софта для работы с Парадоксовскими таблицами, практически можно найти программы на любой вкус и для любых целей.
©Drkb::02960.
| Parsing XML. |
Code: { Here I will show one way to parse XML document. The main concept of XML is using containers for XML objects - So we will use Tree concept while building our XML object from XML document. XML text uses containers (<TAG ... >...</TAG>) or simple definitions (<TAG ... />). In each TAG we can use parameters (<TAG key1="value1" key2="value2">... <SIMPLE key3="value3"> ...</TAG>). Finally we will have an array of objects, describing XML tags. Every object of this. Class will have an array of children if needed, and a hash to describe properties of it. For example if we have a text. <UL name="xxx"> <LI name="xxx1"/> <LI name="xxx2"/> <LI name="xxx3"/> <LI name="xxx4"/> </UL> We will have one root object (named "UL") in wich we will have 4 children. (named "LI" with different sets of properties - from "NAME"="xxx1" to "NAME"="xxx4"). This is not a trivial task - so we will make a unit to solve this... I will try to comment some here... If you have any comments for this unit - write to me: sunworx@mail.ru; yz@infoteh.ru. } Unit YZXMLParser; Interface. Uses. SysUtils, ComCtrls; Type. THashElement = record. Key, Value: string; End; Type. THashElementArr = array of THashElement; // here we declare a THash class to use in our parser. // The concept of THash is to retreive named values from an array. // Hash is an array where index is a string (example V[Key]=value, // whehe Key and Value are of type string). // The main purpose of this class is to rerurn a value of a String-named key. //(example: s:=hash['someValue']). // the description of a hash element we use. Type. THash = class(TObject). Private. Arr: THashElementArr; Function GetValue(Key: string): string; Procedure SetValue(Key: string; const VValue: string); Function GetKeys: StrArr; Function GetValues: StrArr; Function GetCount: Integer; Function Getempty: Boolean; Public. Property Value[Key: string]: string read GetValue write SetValue; default; Property Values: StrArr read GetValues; Property Keys: StrArr read GetKeys; Property Count: Integer read GetCount; Property Empty: Boolean read Getempty; Procedure Clear; Constructor Create; Destructor Destroy; override; End; TYZHash = THash; Type. // Here we declare some definitions for our parser to know what. // identifier we would receive next in our text. // these values will be used in the result of WhatNext() function which will scan text for keys. TYZXMLMarker = (xmlOpenTag, xmlCloseTagShort, xmlCloseTag, xmlCloseTagLong, XmlEOF, xmlIdentifier, xmlunknown); / * Because we use recursive definition of our class(as TreeView, where we declare children of. The same type in opur type. Declaration) we must use forward declaration. * / // The definition of a TAG class. TYZXMLTag = class; TYZXMLTags = array of TYZXMLTag; TYZXMLTag = class(TObject). Private. FData: TYZHash; FParent: TYZXMLTag; FName: string; Function GetValue(AName: string): string; Procedure SetName(const Value: string); Procedure SetValue(AName: string; const Value: string); Function GetCount: Integer; Function GetValueNames: strarr; Public. Children: TYZXMLTags; // these are our child nodes. Text: string; Property Name: string read FName write SetName; // name of a tag. Property Values[AName: string]: string read GetValue write SetValue; Default; // values of properties of a tag (hash values). Property ValueNames: strarr read GetValueNames; // array of strings returniong names of all props of this tag. Property Count: Integer read GetCount; // a count of children of a tag (if this tag is a container). Function SkipSpaces(var AData: string; var APos: Integer; RememberBreaks: Boolean = False): Char; // internal. for skip spaces (also CR or LF or other non-text chars) while parsing text. Function ParseValue(var AData: string; var APos: Integer): Boolean; // parse value (calling when found a parameter of a tag). Function ParseName(var AData: string; var APos: Integer): Boolean; // parse key of parameter in a tag. // these two procs used to parse any text found while parsing XML. Function ParseString(var AData: string; var APos: Integer; RememberBreaks: Boolean = False): string; Function ParseQuotedString(var AData: string; var APos: Integer; QIndef: Char = '"'): string; // returnes the type of next identifier in XML. Function WhatNext(var AData: string; var APos: Integer; Var ANext: Integer; RememberBreaks: Boolean = False): TYZXMLMarker; // This is a main procedure of our class - AData is a string, // containing all XML data (you can use TMemo.Text, for example, as a parameter of AData). Function ParseXML(var AData: string; var APos: Integer): Boolean; // This function returnes a text string, built based on data, stored in an object. Function GenerateXML(var AData: string; ATab: string = ''): Boolean; // returnes char from string at specified pos (#0 if not in range). Function CharAt(var S: string; APos: Integer): Char; Function TagNameExists(AName: string): Boolean; // Adds a child to children array of a current tag. Function AddChild: TYZXMLTag; // Initializes current tag and deletes all existing children. Procedure Clear; virtual; Constructor Create(AParent: TYZXMLTag); virtual; Destructor Destroy; virtual; End; Type. TYZXMLParser = class(TYZXMLTag). Private. Header: TYZHash; Procedure _BuildTreeView(ATreeView: TTreeView; ANode: TTreeNode; ATag: TYZXMLTag); Public. Property HeaderValues: TYZHash read Header; Procedure BuildTreeView(ATreeView: TTreeView); Function Parse(AData: string): Boolean; Function Generate(var AData: string): Boolean; Constructor Create; Destructor Destroy; End; Implementation. //============================================================================== { TYZXMLTag }. Function TYZXMLTag.AddChild: TYZXMLTag; Begin. Setlength(children, Length(children) + 1); Result := TYZXMLTag.Create(Self); Children[Length(children) - 1] := Result; End; //------------------------------------------------------------------------------ Procedure TYZXMLTag.Clear; Var. I: Integer; Begin. For i := 0 to Count - 1 do if children[i] <> nil then Children[i].Destroy; Setlength(children, 0); FData.Clear; Text := ''; End; //------------------------------------------------------------------------------ Constructor TYZXMLTag.Create(AParent: TYZXMLTag); Begin. Inherited Create; FData := TYZHash.Create; FParent := AParent; Clear; End; //------------------------------------------------------------------------------ Destructor TYZXMLTag.Destroy; Begin. Clear; FData.Destroy; End; //------------------------------------------------------------------------------ Function TYZXMLTag.GetCount: Integer; Begin. Result := Length(children); End; //------------------------------------------------------------------------------ Function TYZXMLTag.GetValue(AName: string): string; Begin. Result := FData[AName]; End; //------------------------------------------------------------------------------ Function TYZXMLTag.ParseName(var AData: string; var APos: Integer): Boolean; Begin. Result := False; FName := ParseString(AData, APos); If fname = '' then Exit; Result := True; End; //------------------------------------------------------------------------------ Function TYZXMLTag.ParseQuotedString(var AData: string; var APos: Integer; QIndef: Char = '"'): string; Var. I: Integer; Skipnext: Boolean; Z: Char; Begin. Result := ''; If CharAt(AData, APos) <> QIndef then Exit; I := apos; Skipnext := True; Repeat. If not skipnext then. Begin. If charat(AData, I) = '\' then SkipNext := True. Else. Begin. Z := charat(AData, I); If (Z = QIndef) or (z = #0) then. Begin. Result := Copy(AData, aPos + 1, I - APos - 1); // result:=exch(result,'\',''); APos := I + 1; Exit; End; End; End. Else. Skipnext := False; Inc(i); Until False; End; //------------------------------------------------------------------------------ Function TYZXMLTag.ParseString(var AData: string; var APos: Integer; RememberBreaks: Boolean = False): string; Const. Extsym: string = '=<>;?*/'; Var. Nxt: Char; X1, x2, i: Integer; Begin. Result := ''; Nxt := SkipSpaces(AData, APos, RememberBreaks); If nxt = #0 then Exit; If (nxt = '"') or (nxt = '''') then. Begin. Result := ParseQuotedString(AData, APos); Exit; End; X1 := APos; I := x1; Nxt := CharAt(AData, i); While ((Ord(nxt) <= 32) or (Pos(nxt, extsym) > 0)) and (nxt <> #0) do. Begin. Inc(i); Nxt := CharAt(AData, i); End; APos := i; X1 := APos; While (Ord(nxt) > 32) and (Pos(nxt, extsym) <= 0) do. Begin. Inc(i); Nxt := CharAt(AData, i); End; X2 := i - x1; Result := Copy(AData, x1, x2); APos := i; End; //------------------------------------------------------------------------------ Function TYZXMLTag.ParseValue(var AData: string; var APos: Integer): Boolean; Var. N, v: string; I, x: Integer; Begin. Result := False; N := parseString(AData, APos); If n = '' then Exit; If skipspaces(AData, APos) <> '=' then Exit; Inc(apos); V := parseString(AData, APos); Fdata[n] := dequote(v); Result := True; End; //------------------------------------------------------------------------------ Function TYZXMLTag.ParseXML(var AData: string; var APos: Integer): Boolean; Var. N: TYZXMLMarker; Nxt: Integer; IsLong: Boolean; InTag: Boolean; Begin. IsLong := False; Result := False; Clear; If WhatNext(AData, APos, nxt) <> xmlOpenTag then Exit; APos := nxt; If WhatNext(AData, APos, nxt) <> xmlIdentifier then Exit; Result := ParseName(AData, APos); If not Result then Exit; Intag := True; Result := False; While True do. Begin. N := WhatNext(AData, APos, nxt, (not intag and islong and (Count > 0))); Case N of. XmlEOF: Exit; XmlCloseTagLong: Begin. Result := True; If islong then APos := nxt; If (Text <> '') and (Count > 0) then. Begin. Text := exch(Text, #13#10#13#10, #13#10); End; Exit; End; XmlCloseTagShort: Begin. Result := (not IsLong) and intag; If Result then APos := nxt; Exit; End; XmlOpenTag: Begin. If islong then Result := AddChild.ParseXML(AData, APos). Else. Begin. Result := False; Exit; End; If not Result then Exit; End; XmlCloseTag: Begin. IsLong := True; APos := nxt; Intag := False; End; XmlIdentifier: Begin. If intag then parsevalue(AData, APos). Else. Text := Text + ParseString(AData, APos, True). End; XmlUnknown: Begin. Result := True; Exit; End; End; End; End; //------------------------------------------------------------------------------ Procedure TYZXMLTag.SetName(const Value: string); Begin. FName := Value; End; //------------------------------------------------------------------------------ Procedure TYZXMLTag.SetValue(AName: string; const Value: string); Begin. FData[AName] := Value; End; //------------------------------------------------------------------------------ Function TYZXMLTag.SkipSpaces(var AData: string; var APos: Integer; RememberBreaks: Boolean = False): Char; Var. L: Integer; P: Char; Begin. L := Length(AData); While APos <= L do. Begin. P := AData[APos]; If Ord(p) > 32 then. Begin. Result := p; Exit; End. Else if rememberbreaks then. Begin. If Pos(p, #13#9' ') > 0 then. Text := Text + ' '; End; Inc(APos); End; Result := #0; End; //------------------------------------------------------------------------------ Function TYZXMLTag.CharAt(var S: string; APos: Integer): Char; Begin. Result := #0; If (Length(s) < APos) or (apos < 1) then Exit; Result := s[APos]; End; //------------------------------------------------------------------------------ Function TYZXMLTag.WhatNext(var AData: string; var APos: Integer; Var ANext: Integer; RememberBreaks: Boolean = False): TYZXMLMarker; Var. S: string; C: Char; P: Integer; Begin. Result := xmlEOF; P := APos; C := SkipSpaces(AData, APos); P := APos; ANext := P; If C = #0 then Exit; If C = '<' then if CharAt(AData, P + 1) = '/' then. Begin. Inc(P, 2); S := parsestring(AData, P); If (uppercase(s) = uppercase(FName)) and (SkipSpaces(AData, P) = '>') then. Begin. ANext := P + 1; Result := xmlCloseTagLong; Exit; End. Else. Begin. If TagNameExists(s) then. Begin. Result := xmlCloseTagLong; ANext := APos; Exit; End; ANext := P + 1; Result := xmlCloseTagLong; Exit; End; End; If C = '<' then. Begin. ANext := P + 1; Result := xmlOpenTag; Exit; End; If C = '>' then. Begin. ANext := P + 1; Result := xmlCloseTag; Exit; End; If C = '/' then if CharAt(AData, P + 1) = '>' then. Begin. ANext := P + 2; Result := xmlCloseTagShort; Exit; End; ANext := P; Parsestring(AData, ANext); Result := xmlIdentifier; End; //------------------------------------------------------------------------------ Function TYZXMLTag.GetValueNames: strarr; Begin. Result := FData.Keys; End; //------------------------------------------------------------------------------ Function TYZXMLTag.GenerateXML(var AData: string; ATab: string = ''): Boolean; Var. ValDelimiter: string; Spc: string; I: Integer; A: strarr; Begin. Spc := ATab + #9; If FData.Count < 5 then valDelimiter := ' ' Else. ValDelimiter := #13#10 + spc; AData := AData + #13#10 + ATab + '<' + FName; A := FData.keys; For i := 0 to Length(a) - 1 do. Begin. AData := AData + valDelimiter + a[i] + ' = "' + EnQuote(values[a[i]]) + '"'; End; If (Count > 0) or (Text <> '') then. Begin. AData := AData + '>' + Text; For i := 0 to Count - 1 do. Begin. Children[i].GenerateXML(AData, ATab + #9); End; AData := AData + #13#10 + ATab + '</' + FName + '>'; End. Else. AData := AData + '/>'; Result := True; End; //------------------------------------------------------------------------------ Function TYZXMLTag.TagNameExists(AName: string): Boolean; Begin. Result := AnsiUpperCase(AName) = AnsiUpperCase(Self.FName); If Self.FParent = nil then Exit; If not Result then Result := fparent.TagNameExists(AName); End; //============================================================================== { TYZXMLParser }. Constructor TYZXMLParser.Create; Begin. Header := TYZHash.Create; Inherited Create(nil); End; //------------------------------------------------------------------------------ Destructor TYZXMLParser.Destroy; Begin. Inherited; Header.Destroy; End; //------------------------------------------------------------------------------ Procedure TYZXMLParser.BuildTreeView(ATreeView: TTreeView); Var. I: Integer; Begin. // clear; ATreeView.Items.Clear; For i := 0 to Count - 1 do _BuildTreeView(ATreeView, nil, children[i]); End; //------------------------------------------------------------------------------ Procedure TYZXMLParser._BuildTreeView(ATreeView: TTreeView; ANode: TTreeNode; ATag: TYZXMLTag); Var. I: Integer; N: TTreeNode; Begin. N := ATreeView.Items.AddChildObject(ANode, ATag.Name + ' ' + FData['ID'], Pointer(ATag)); For i := 0 to ATag.Count - 1 do. Begin. If ATag.children[i] <> nil then _BuildTreeView(ATreeView, N, ATag.children[i]). Else. ATreeView.Items.AddChild(N, 'nil'); End; N.Expanded := True; End; //------------------------------------------------------------------------------ Function TYZXMLParser.Parse(AData: string): Boolean; Var. X1, x2, X, i: Integer; S: string; Tmp: TYZXMLTag; A: strarr; N: TYZXMLMarker; Begin. X := 1; Self.SkipSpaces(AData, X); X2 := -1; Result := False; Clear; Header.Clear; X1 := Pos('<?', AData); If x1 >= X then. Begin. X2 := Pos('?>', AData); If x2 < X then Exit; S := uppercase(Copy(AData, x1 + 2, 4)); If Pos('XML ', s) <> 1 then Exit; S := '<xml ' + Copy(AData, x1 + 6, x2 - x1 - 6) + '/>'; Tmp := TYZXMLTag.Create(nil); Tmp.ParseXML(s, x); A := tmp.ValueNames; For i := 0 to Length(a) - 1 do. Header[a[i]] := tmp.Values[a[i]]; Tmp.Destroy; X := x2 + 2; End; Result := True; Repeat. N := whatnext(AData, X, x1); Case N of. XmlOpenTag: Result := Result and AddChild.ParseXML(AData, X); XmlIdentifier: Begin. If Text <> '' then Text := Text + ' '; Text := Text + parsestring(AData, X, True); End; Else. Parsestring(AData, X); End; Until skipspaces(adata, x) = #0; // if not result then ShowMessage('Error Parsing: '+inttostr(X)); End; Function TYZXMLParser.Generate(var AData: string): Boolean; Var. I: Integer; A: strarr; Begin. Header['Date'] := DateTimeToStr(now); A := header.Keys; AData := '<?xml'; For i := 0 to Length(a) - 1 do. AData := AData + ' ' + a[i] + '="' + Header[a[i]] + '"'; AData := AData + '?>'#13#10 + Text; Result := True; For i := 0 to Length(children) - 1 do. Begin. Result := Result and children[i].generatexml(AData); End; End; //============================================================================== // procedures of THash class. //============================================================================== {THASH CLASS}. Procedure THash.Clear; Begin. SetLength(Arr, 0); End; Constructor THash.Create; Begin. Inherited; Clear; End; //------------------------------------------------------------------------------ Destructor THash.Destroy; Begin. Clear; Inherited; End; //------------------------------------------------------------------------------ Function THash.GetCount: Integer; Begin. Result := Length(Arr); End; //------------------------------------------------------------------------------ Function THash.Getempty: Boolean; Begin. Result := Length(Arr) = 0; End; Function THash.GetKeys: StrArr; Var. I: Integer; Begin. SetLength(Result, Length(arr)); For i := 0 to Length(Result) - 1 do. Result[i] := arr[i].Key; End; //------------------------------------------------------------------------------ Function THash.GetValue(Key: string): string; Var. I: Integer; R: Boolean; Begin. Result := ''; I := 0; R := False; While (i < Length(Arr)) and (not r) do. Begin. If AnsiUpperCase(arr[i].key) = AnsiUpperCase(Key) then. Begin. Result := Arr[i].Value; R := True; End; I := i + 1; End; End; //------------------------------------------------------------------------------ Function THash.GetValues: StrArr; Var. I: Integer; Begin. SetLength(Result, Length(arr)); For i := 0 to Length(Result) - 1 do. Result[i] := arr[i].Value; End; //------------------------------------------------------------------------------ Procedure THash.SetValue(Key: string; const VValue: string); Var. I, j: Integer; R: Boolean; E: THashElementArr; Begin. If VValue <> '' then. Begin. I := 0; R := False; While (i < Length(Arr)) and not r do. Begin. If AnsiUpperCase(arr[i].key) = AnsiUpperCase(Key) then. Begin. Arr[i].Value := VValue; R := True; End; I := i + 1; End; If not r then. Begin. SetLength(Arr, Length(arr) + 1); Arr[Length(arr) - 1].Key := Key; Arr[Length(arr) - 1].Value := Vvalue; End; End; SetLength(E, Length(Arr)); For i := 0 to Length(arr) - 1 do E[i] := Arr[i]; SetLength(arr, 0); For i := 0 to Length(E) - 1 do if (E[i].Key <> '') and (E[i].Value <> '') then. Begin. J := Length(arr); Setlength(arr, j + 1); Arr[j] := E[i]; End; End; End.
| PChar-->Integer. |
Many Windows functions claim to want PChar parameters in the documentation, but they are defined as requiring LongInts.
Is this a bug?
| PGPSDK - легкий путь к шифрованию |
Автор: Евгений Дадыков
PID and SID процесса.
| PID and SID процесса |
Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. 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) на
Code: HProcess := OpenProcess(PROCESS_QUERY_INFORMATION, True, PID); If hProcess <> 0 then. Try. // теперь заменяй GetCurrentProcess значением из hProcess. Finally. CloseHandle(hProcess); End;
Взято из http://forum.sources.ru.
Автор: Rouse_
©Drkb::02125.
| Popsock.pas. |
Code: 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.
| Power off. |
Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Power off (Убивает процессы). Зависимости: Windows. Автор: DeMoN-777, DeMoN-777@yandex.ru, Санкт-Петербург. Copyright: @ Дата: 21 июня 2002 г. ***************************************************** } Procedure Shutdown2; Var. HToken: THandle; Tkp: _TOKEN_PRIVILEGES; DUMMY: PTokenPrivileges; DummyRL: Cardinal; Begin. DUMMY := nil; If not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, HToken. ) then. Raise TShutdownEx.Create('OpenProcessToken failed'); If (not LookupPrivilegeValue(nil, 'SeShutdownPrivilege', Tkp.Privileges[0].Luid)) then. Raise TShutdownEx.Create('LookupPrivilegeValue failed'); Tkp.PrivilegeCount := 1; Tkp.Privileges[0].Attributes := $0002; //SE_PRIVILEGE_ENABLED = $00002. AdjustTokenPrivileges(hToken, FALSE, tkp, 0, Dummy, DummyRL); If (GetLastError() <> ERROR_SUCCESS) then. Raise TShutdownEx.Create('AdjustTokenPrivileges failed'); If (not ExitWindowsEx(EWX_SHUTDOWN or EWX_FORCE, 0)) then. Raise TShutdownEx.Create('ExitWindowsEx failed'); End;
©Drkb::01688.
Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Power off (не убивает процессы). Зависимости: Windows. Автор: DeMoN-777, DeMoN-777@yandex.ru, Санкт-Петербург. Copyright: @ Дата: 21 июня 2002 г. ***************************************************** } Procedure ExitWinNT(AShutdown: Boolean); Var. HToken: THandle; Tkp: TTokenPrivileges; ReturnLength, What: Cardinal; Begin. If AShutdown then. What := EWX_SHUTDOWN or EWX_POWEROFF. Else. What := EWX_REBOOT; If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or. TOKEN_QUERY, hToken) then. Begin. LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid); Tkp.PrivilegeCount := 1; Tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; If AdjustTokenPrivileges(hToken, False, tkp, 0, nil, ReturnLength) then. ExitWindowsEx(What, 0). End. End; Пример использования: ExitWinNT(True);
©Drkb::01689.
PPP.
Author: John Wobus, jmwobus@syr.edu (corrections welcome).
Оpигинал #1: http://cs.uni-bonn.de/ppp/part1.html.
Оpигинал #2: http://www.cisco.com/univercd/cc/td/doc/cisintwk/
/ito_doc/55168.htm.
Пеpевод: осуществлен Гоpоховым Виталием (GSLab@email.com) в
Pамках поддеpжки FAQ'а по эхоконфеpенциям Su.net и Ru.Lan.nw.
Access to: http://netware.inter.net.md.
-----------------------------------------------------------------------------
Point-to-Point Protocol (PPP) pазpаботан для pазpешения пpоблем связанных с
недостаточным количеством стандаpтных сpедств инкапсуляции пpотоколов вида
"point-to-point IP". Ко всему пpочемубыл также pазpаботан для упpощения
выдачи и упpавления IP адpесами, асинхpонной и bit-oriented синхpонной
инкапсуляцией, смешивания сетевых пpотоколов(network protocol multiplexing),
конфигуpиpования и тестиpования качества связи, обнаpужения ошибок и
опциями для установления таких особеностей сетевого уpовня как настpойка
адpесов и установка сжатия данных. Для поддеpжки выше пеpечисленных качеств,
должен пpедоставлять упpавление по pасшиpенному Link Control Protocol.
(LCP) и семейству пpотоколов Network Control Protocols (NCPs) котоpые
используются для установления паpаметpов связи. На сегодняшний день
поддеpживает не только IP, но и дpугие пpотоколы, включая IPX и DECNet.
PPP Components.
--------------
пpедоставляет возможность пеpедачи датагpамм по последовательным
Point-to-point линиям. Он имеет 3 компоненты:
X Метод пpедоставления инкапсуляции датагpамм по последовательным
PPP линиям используя HDLC (High-Level Data Link Control) пpотокол
для упаковки датагpамм посpедствам связи.
X Расшиpенный LCP(Link Control Protocol) для установления, конфигуpиpования
и тестиpования физического соединения (test the data-link connection).
X Семейство пpотоколов (NCPs) для установления и упpавления иными сетевыми
пpотоколами, иными словами: PPP pазpаботан для поддеpжки одновpеменно
нескольких сетевых пpотоколов.
General Operation.
-----------------
В момент установления связи чеpезсоединение, PPP дpайвеp вначале шлет
пакеты LCP для конфигуpиpования и (возможно) тестиpования линии связи.
После того как связь и дополнительные возможности будут установлены как надо
посpедством LCP, PPP дpайвеp посылает NCP фpеймы для изменения и/или
настpойки одного или более сетевых пpотоколов. Когда этот пpоцесс закончиться,
то сетевые пакеты получают возможность быть пеpеданными чеpез установленное
соединение. Оно будет оставаться настpоенным и активным до тех поp, пока
опpеделенные LCP или NCP пакеты не закpоют соединение, или до тех поp пока
не пpоизойдет какое-нибудь внешнее событие, котоpое пpиведет к потеpе
соединения (к пpимеpу: таймеp отсутствия активности или вмешательство
пользователя).
Physical-Layer Requirements.
---------------------------
адаптиpован для pаботы с любым DTE/DCE интеpфейсом, включая EIA/TIA-232-C.
(RS-232), EIA/TIA-422-C(RS-422), EIA/TIA-423-C(RS-423), ITU-T (CCITT) V.35.
Единственное тpебование к обоpудованию, налагаемое PPP - это наличие
дуплексного обоpудования, не важно выделенное оно или пеpеключаемое
(either dedicated or switched), котоpое может pаботать на асинхpонных или
Bit-oriented синхpонных, пpозpачных дляпакетах.
PPP Link Layer.
--------------
использует пpинципы, теpминологию и стpуктуpу пакетов в описанных ISO.
документах касающихся HDLC (ISO 3309-1979) и его дополненной веpсии:
ISO 3309:1984/PDAD1 "Addendum 1: Start/stop transmission.".
ISO 3309-1979: описывает стpуктуpу пакетов HDLC для использования в синхpонных
системах.
ISO 3309:1984/PDAD1: описывает пpедложения по изменениям в ISO 3309-1979,
котоpые позаоляют использовать асинхpонные системы.
Пpоцедуpы упpавленияиспользуют опpеделения и упpавляющие поля
стандаpтизиpованные в документах: ISO 4335-1979 и
ISO 4335-1979/Addendum 1-1979.
Фоpмат пакета PPP:
(Длина пакета в байтах).
1 1 1 2 Variable 2 или 4.
--------------------------------- - - ----------------
| F | | | | | |
| l |Add |Con | Protocol| | |
| a | re | trol | | D A T A | F C S |
| g | ss | | | | |
| | | | | | |
---------------------------------- - - ----------------
Flag: Один байт обозначающий начало или конец пакета
Поле флага содеpжит двоичную последовательность: 01111110.
Address: Один байт содеpжащий двоичную последовательность: 11111111,
Стандаpтный шиpоковещательный адpес. PPP не поддеpживает
индивидуальную адpесацию станций.
Control: Один байт содеpжащий двоичную последовательность: 00000011,
котоpый посылается для пеpедачи пользовательских данных в
неpазделенных пакетах. (for transmission of user data in.
An unsequenced frame.
Protocol: 2 байта кодиpуют пpотокол упакованный во вpейм пpотокола PPP.
Значения пpотоколов можно узнать документе Assigned Numbers.
Request for Comments (RFC).
Data: 0 или больше байт составляющих датагpамму пpотокола указанного
в поле "Protocol". Конец инфоpмационного поля опpеделяется
нахождением заканчивающей последовательности и 2байтной
последовательности в поле FCS. По умолчанию максимальная длина
инфpмационоого поля 1500байт.Однако, по взаимной "договоpенности",
учитывая использованиемогут использоваться иные значения
длины поля
Frame Check Sequence (FCS): Обычно 16bit (2байта). Однако, по взаимной
"договоpенности" может использоваться и 32bit (4байта).
котpоль целостности пакетов.
PPP Link Control Protocol.
-------------------------
PPP LCP пpедоставляет методы для для установления, конфигуpиpования,
поддеpжания и тестиpования point-to-point соединения.
LCP pаспадается на 4 фазы:
X Конфигуpиpование и установление связи - Пеpед пеpедачей какой-либо
датагpаммы (к пpимеpу IP) LCP должен в начале откpыть соединение и
пpоизвести начальный обмен паpаметpами настpойки. Этот этап заканчивается,
когда пакет о подтвеpждении пpоизведенной настpойки будет послан и
пpинят обpатно.
X Опpеделение качества связи - LCP позволяет (но не тpебует) добавить фазу
тестиpования канала связи, эта фаза будет следовать сpазу-же за пеpвой.
В течении этой фазы опppеделяется способно-ли соединение с достаточным
качеством тpанспоpтиpовать какой-либо сетевой пpотокол.
Эта фаза не является обязательной. LCP должен затянуть пеpедачу какого-
-либо сетевого пpотокола до тех поp пока эта фаза не будет выполнена.
X Установление настpоек сетевого пpотокола - После того как LCP закончит
опpеделение паpаметpов связи, сетевые пpотоколы должны быть независимо
дpуг от дpуга настpоены соответствующими NCP, котоpыми могут в любой
момент вpемени начать или пpекpатить пользоваться.
XОкончание связи - LCP может в любое вpемя пpеpвать установленную связь.
Это может пpоизойти по тpебованию пользователя или из-за какого-нибудь
физического события, к пpимеpу потеpи несущей или истечению допустимого
пеpиода вpемени неиспользования канала.
*Существует тpи типа LCP пекетов:
XПакеты установления- Используются для установления и настpойки связи
XПакеты пpеpывания - Используются для пpеpывания установленной связи
XПакеты сохpанения связи - Используются для упpавления и диагностики связи
©Drkb::03362.
| Как получить primary domain controller (PDC)? |
Code: { The NetGetDCName function returns the name of the primary domain controller (PDC). It does not return the name of the backup domain controller (BDC) for the specified domain. Also, you cannot remote this function to a non-PDC server. Windows 2000/XP: Applications that support DNS-style names should call the function. Domain controllers in this type of environment have a multi-master. Directory replication relationship. Therefore, it may be advantageous for your application to use a DC that is not the PDC. You can call the DsGetDcName function to locate any DC in the domain; NetGetDCName returns only the name of the PDC. } Type. EAccessDenied = Exception; EInvalidOwner = Exception; EInsufficientBuffer = Exception; ELibraryNotFound = Exception; NET_API_STATUS = Integer; Const. NERR_Success = 0; Var. NTNetGetDCName: function (Server, Domain: pWideChar; var DC: pWideChar): NET_API_STATUS; stdcall; NTNetGetDCNameA: function (Server, Domain: PChar; var DC: PChar): NET_API_STATUS; stdcall; NTNetApiBufferFree: function (lpBuffer: Pointer): NET_API_STATUS; stdcall; Procedure NetCheck(ErrCode: NET_API_STATUS); Begin. If ErrCode <> NERR_Success then. Begin. Case ErrCode of. ERROR_ACCESS_DENIED: Raise EAccessDenied.Create('Access is Denied'); ERROR_INVALID_OWNER: Raise EInvalidOwner.Create('Cannot assign the owner of this object.'); ERROR_INSUFFICIENT_BUFFER: Raise EInsufficientBuffer.Create('Buffer passed was too small'); Else. Raise Exception.Create('Error Code: ' + IntToStr(ErrCode) + #13 + SysErrorMessage(ErrCode)); End; End; End; Function GetPDC(szSystem: string): string; { if szSystem = '' return the PDC else return DC for that domain }. Const. NTlib = 'NETAPI32.DLL'; Win95lib = 'RADMIN32.DLL'; Var. PAnsiDomain: PChar; PDomain: PWideChar; System: array[1..80] of WideChar; ErrMode: Word; LibHandle: THandle; Begin. Result := ''; LibHandle := 0; Try. If Win32Platform = VER_PLATFORM_WIN32_NT then. Begin. ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); LibHandle := LoadLibrary(NTlib); SetErrorMode(ErrMode); If LibHandle = 0 then. Raise ELibraryNotFound.Create('Unable to map library: ' + NTlib); @NTNetGetDCName := GetProcAddress(Libhandle, 'NetGetDCName'); @NTNetApiBufferFree := GetProcAddress(Libhandle, 'NetApiBufferFree'); Try. If szSystem <> '' then. NetCheck(NTNetGetDCName(nil, StringToWideChar(szSystem, @System, 80), pDomain)). Else. NetCheck(NTNetGetDCName(nil, nil, pDomain)); Result := WideCharToString(pDomain); Finally. NetCheck(NTNetApiBufferFree(pDomain)); End; End. Else. Begin. ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); LibHandle := LoadLibrary(Win95lib); SetErrorMode(ErrMode); If LibHandle = 0 then. Raise ELibraryNotFound.Create('Unable to map library: ' + Win95lib); @NTNetGetDCNameA := GetProcAddress(Libhandle, 'NetGetDCNameA'); @NTNetApiBufferFree := GetProcAddress(LibHandle, 'NetApiBufferFree'); Try. If szSystem <> '' then. NetCheck(NTNetGetDCNameA(nil, PChar(szSystem), pAnsiDomain)). Else. NetCheck(NTNetGetDCNameA(nil, nil, pAnsiDomain)); Result := StrPas(pAnsiDomain); Finally. NetCheck(NTNetApiBufferFree(pAnsiDomain)); End; End; Finally. If LibHandle <> 0 then. Begin. FreeLibrary(Libhandle); // free handle if it has been allocated. End; End; End; // Example call, Beispielaufruf: Procedure TForm1.Button1Click(Sender: TObject); Begin. Try. Screen.Cursor := crHourGlass; Label1.Caption := GetPDC(''); Finally. Screen.Cursor := crDefault; End; End;
Print Preview.
Code: Unit printpreview; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls; Type. TForm1 = class(TForm). Panel1: TPanel; Panel2: TPanel; PreviewPaintbox: TPaintBox; Label1: TLabel; Label2: TLabel; LeftMarginEdit: TEdit; TopMarginEdit: TEdit; Label3: TLabel; Label4: TLabel; RightMarginEdit: TEdit; Label5: TLabel; BottomMarginEdit: TEdit; ApplyMarginsButton: TButton; OrientationRGroup: TRadioGroup; Label6: TLabel; ZoomEdit: TEdit; ZoomUpDown: TUpDown; Procedure LeftMarginEditKeyPress(Sender: TObject; var Key: Char); Procedure FormCreate(Sender: TObject); Procedure PreviewPaintboxPaint(Sender: TObject); Procedure ApplyMarginsButtonClick(Sender: TObject); Private. { Private declarations }. PreviewText: String; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. Uses printers; {$R *.DFM}. Procedure TForm1.LeftMarginEditKeyPress(Sender: TObject; var Key: Char); Begin. If not (Key in ['0'..'9',#9,DecimalSeparator]) Then. Key := #0; End; Procedure TForm1.FormCreate(Sender: TObject); Var. S: String; Procedure loadpreviewtext; Var. Sl: TStringlist; Begin. Sl:= Tstringlist.Create; Try. Sl.Loadfromfile( Extractfilepath( application.exename )+'printpreview.pas'); PreviewText := sl.Text; Finally. Sl.free. End; End; Begin. // Initialize the margin edits with a margin of 0.75 inch. S:= FormatFloat('0.00',0.75); LeftMarginEdit.Text := S; TopMarginEdit.Text := S; RightMarginEdit.Text := S; BottomMarginEdit.Text := S; // Initialize the orientation radio group. If Printer.Orientation = poPortrait Then. OrientationRGroup.ItemIndex := 0. Else. OrientationRGroup.ItemIndex := 1; // load test text for display. LoadPreviewtext; End; Procedure TForm1.PreviewPaintboxPaint(Sender: TObject); Var. Pagewidth, pageheight: Double; // printer page dimension in inch. PrinterResX, printerResY: Integer; // printer resolution in dots/inch. MinmarginX, minmarginY: Double; // nonprintable margin in inch. Outputarea: TRect; // print area in 1/1000 inches. Scale: Double; // conversion factor, pixels per 1/1000 inch. Procedure InitPrintSettings; Function GetMargin( S: String; inX: Boolean ):Double; Begin. Result := StrToFloat(S); If InX then begin. If Result < minmarginX then. Result := minmarginX; End. Else begin. If Result < minmarginY then. Result := minmarginY; End; End; Begin. PrinterResX := GetDeviceCaps( printer.handle, LOGPIXELSX ); PrinterResY := GetDeviceCaps( printer.handle, LOGPIXELSY ); Pagewidth := GetDeviceCaps( printer.handle, PHYSICALWIDTH ) / printerResX; Pageheight := GetDeviceCaps( printer.handle, PHYSICALHEIGHT) / printerResY; MinmarginX := GetDeviceCaps( printer.handle, PHYSICALOFFSETX)/ printerResX; MinmarginY := GetDeviceCaps( printer.handle, PHYSICALOFFSETY)/ printerResY; Outputarea.Left := Round( GetMargin( LeftMarginEdit.Text, true ) * 1000); Outputarea.Top := Round( GetMargin( TopMarginEdit.Text, false ) * 1000); Outputarea.Right := Round(( pagewidth - GetMargin( RightMarginEdit.Text, true )) * 1000); Outputarea.Bottom := Round(( pageheight - GetMargin( BottomMarginEdit.Text, false )). * 1000); End; { InitPrintSettings }.
©Drkb::03260.
Problem generating font matrix in Kylix.
My install of Kylix was successfull but after startup with "startkylix" I see the message "generating font matrix" forever. What should I do about this?
If you installed as root the font matrix will be created for each user the first time they start Kylix. How long it takes depends on the number of fonts that you have installed and the speed of your machine. If it seems to freeze or last a long time you should still be able to run Kylix even if you terminate the font matrix generation.
Possible workarounds.
This problem could be caused by a bad truetype font. If you have any Windows tt-fonts installed try removing them. Another thing to try is to change the order of the font search path in XF86Config or in your tt-fontserver. Try to put the tt-fonts at the end of the list.
Here is another suggestion from our newsgroups:
Rename the file "transdlg" located in your Kylix bin directory to "transdlg.renamed" and then run Kylix.
This is an issue we are currently looking into. This document will be updated when more information is available.
©Drkb::04608.
ProgressBar в колонке TListView.
| ProgressBar в колонке TListView. |
Code: 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;
©Drkb::00964.
DelphiWorld 6.0.
| ProgressBar с невидимой рамкой |
Автор: VS.
| PWideChar --> String. |
| TStatusBar+TProgressBar. |
Вставить ProgressBar в StatusBar:
Вот эту функцию применять вместо стандартного Create.
Code: Function CreateProgressBar(StatusBar:TStatusBar; index:integer):TProgressBar; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Var findleft:integer; I:integer; Begin. Result:=TProgressBar.create(Statusbar); Result.parent:=Statusbar; Result.visible:=true; Result.top:=2; Findleft:=0; For i:=0 to index-1 do. Findleft:=findleft+Statusbar.Panels[i].width+1; Result.left:=findleft; Result.width:=Statusbar.Panels[index].width-4; Result.height:=Statusbar.height-2; End;
| Интерполяция изображений. |
Поговорим о том, как качественно увеличить изображение при помощи билинейной интерполяции.
При увеличении изображения нужно находить цвет точек, находящимися между точками исходного изображения. Функция CopyRect, встроенная в Delphi берет для этого цвет ближайшей точки. Увеличенное изображение получается некрасивым. Чтобы избежать этого, используют интерполяцию. Существует несколько видов интерполяции изображения. Наиболее простой из них - билинейный.
Изображение рассматривается как поверхность, цвет - третье измерение. Если изображение цветное, то интерполяция проводится отдельно для трех цветов. Для каждой точки нового изображения с координатами (xo,yo) нужно найти четыре ближайшие точки исходного изображения. Эти точки образуют квадрат. Через две верхние точки проводится прямая f1(x), через две нижние - f2(x). Дальше находятся координаты для точек f1(xo) и f2(xo), через которые проводится третья прямая f3(y). Цвет искомой точки - это f3(yo).
Этот алгоритм хорошо работает при целых или больших коэффициентах увеличения. Но резкие границы размываются. Для уменьшения изображения этот алгоритм также не подходит. Эта программа при нажатии на Button1 увеличивает часть изображения на экране, а при нажатии на Button2 увеличивает открытое изображение.
Code: Procedure Interpolate(var bm: TBitMap; dx, dy: single); Var. Bm1: TBitMap; Z1, z2: single; K, k1, k2: single; X1, y1: integer; C: array [0..1, 0..1, 0..2] of byte; Res: array [0..2] of byte; X, y: integer; Xp, yp: integer; Xo, yo: integer; Col: integer; Pix: TColor; Begin. Bm1 := TBitMap.Create; Bm1.Width := round(bm.Width * dx); Bm1.Height := round(bm.Height * dy); For y := 0 to bm1.Height - 1 do begin. For x := 0 to bm1.Width - 1 do begin. Xo := trunc(x / dx); Yo := trunc(y / dy); X1 := round(xo * dx); Y1 := round(yo * dy); For yp := 0 to 1 do. For xp := 0 to 1 do begin. Pix := bm.Canvas.Pixels[xo + xp, yo + yp]; C[xp, yp, 0] := GetRValue(pix); C[xp, yp, 1] := GetGValue(pix); C[xp, yp, 2] := GetBValue(pix); End; For col := 0 to 2 do begin. K1 := (c[1,0,col] - c[0,0,col]) / dx; Z1 := x * k1 + c[0,0,col] - x1 * k1; K2 := (c[1,1,col] - c[0,1,col]) / dx; Z2 := x * k2 + c[0,1,col] - x1 * k2; K := (z2 - z1) / dy; Res[col] := round(y * k + z1 - y1 * k); End; Bm1.Canvas.Pixels[x,y] := RGB(res[0], res[1], res[2]); End; Form1.Caption := IntToStr(round(100 * y / bm1.Height)) + '%'; Application.ProcessMessages; If Application.Terminated then Exit; End; Bm := bm1; End; Const. Dx = 5.5; Dy = 5.5; Procedure TForm1.Button1Click(Sender: TObject); Const. W = 50; H = 50; Var. Bm: TBitMap; Can: TCanvas; Begin. Bm := TBitMap.Create; Can := TCanvas.Create; Can.Handle := GetDC(0); Bm.Width := w; Bm.Height := h; Bm.Canvas.CopyRect(Bounds(0, 0, w, h), can, Bounds(0, 0, w, h)); ReleaseDC(0, can.Handle); Interpolate(bm, dx, dy); Form1.Canvas.Draw(0, 0, bm); Form1.Caption := 'x: ' + FloatToStr(dx) + ' y: ' + FloatToStr(dy) + ' width: ' + IntToStr(w) + ' height: ' + IntToStr(h); End; Procedure TForm1.Button2Click(Sender: TObject); Var. Bm: TBitMap; Begin. If OpenDialog1.Execute then. Bm.LoadFromFile(OpenDialog1.FileName); Interpolate(bm, dx, dy); Form1.Canvas.Draw(0, 0, bm); Form1.Caption := 'x: ' + FloatToStr(dx) + ' y: ' + FloatToStr(dy) + ' width: ' + IntToStr(bm.Width) + ' height: ' + IntToStr(bm.Height); End;
| Расчет введенной формулы. |
Поговорим о том, как можно рассчитать выражение, заданное в строке (string).
Иногда в программе удобно сделать так, чтобы пользователь мог ввести функцию, а программа строила бы по ней график или высчитывала какое-то значение.
Если нужно многократно вычислить одно и то же выражение с разным аргументом (например, для рисования графика) лучше выделить в отдельную процедуру проверку правильности выражения, преобразования строки к удобному виду и т.д.
Наиболее простой способ посчитать значение выражения, это выполнять все операции, начиная с операций высшего приоритета, заменяя задействованные числа и знаки на результат вычислений. Например, выражение "1+2*3^4/5" этот алгоритм начнет рассчитывать с возведения 3 в степень 4. Символы "3^4" уже не нужны и они заменяются на получившийся результат. Получается: "1+2*81/5". Дальше нужно произвести умножение 2 на 81 и т.д.
Перед вычислением нужно убрать все пробелы из строки, заменить все точки и запятые на стандартный разделитель - DecimalSeparator. Помимо этого все символы переводятся на нижний регистр, заменяются некоторые константы, знак ":" заменяется на "/", а модуль, записанный символами "|" заменяется на функцию "abs". Для различия между отрицательным числом и знаком вычитания и для упрощения алгоритма каждое число окружается символами #.
Чтобы можно было вычислить значения выражения с аргументами, перед каждым вычислением нужно вызывать функцию ChangeVar.
Здесь приведен модуль с этими тремя функциями и пример их использования.
Code: Unit Recognition; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math; Type. TVar = set of char; Procedure Preparation(var s: String; variables: TVar); Function ChangeVar(s: String; c: char; value: extended): String; Function Recogn(st: String; var Num: extended): boolean; Implementation. Procedure Preparation(var s: String; variables: TVar); Const. Operators: set of char = ['+','-','*', '/', '^']; Var. I: integer; Figures: set of char; Begin. Figures := ['0','1','2','3','4','5','6','7','8','9', DecimalSeparator] + variables; // " ". Repeat. I := pos(' ', s); If i <= 0 then break; Delete(s, i, 1); Until 1 = 0; S := LowerCase(s); // ".", ",". If DecimalSeparator = '.' then begin. I := pos(',', s); While i > 0 do begin. S[i] := '.'; I := pos(',', s); End; End else begin. I := pos('.', s); While i > 0 do begin. S[i] := ','; I := pos('.', s); End; End; // Pi. Repeat. I := pos('pi', s); If i <= 0 then break; Delete(s, i, 2); Insert(FloatToStr(Pi), s, i); Until 1 = 0; // ":". Repeat. I := pos(':', s); If i <= 0 then break; S[i] := '/'; Until 1 = 0; // |...| Repeat. I := pos('|', s); If i <= 0 then break; S[i] := 'a'; Insert('bs(', s, i + 1); I := i + 3; Repeat i := i + 1 until (i > Length(s)) or (s[i] = '|'); If s[i] = '|' then s[i] := ')'; Until 1 = 0; // #...# I := 1; Repeat. If s[i] in figures then begin. Insert('#', s, i); I := i + 2; While (s[i] in figures) do i := i + 1; Insert('#', s, i); I := i + 1; End; I := i + 1; Until i > Length(s); End; Function ChangeVar(s: string; c: char; value: extended): String; Var. P: integer; Begin. Result := s; Repeat. P := pos(c, result); If p <= 0 then break; Delete(result, p, 1); Insert(FloatToStr(value), result, p); Until false; End; Function Recogn(st: String; var num: extended): boolean; Const. Pogr = 1E-10; Var. P, p1: integer; I, j: integer; V1, v2: extended; Func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, fAbs, fLn, fLg, fExp); Sign: integer; S: String; S1: String; Function FindLeftValue(p: integer; var Margin: integer; var Value: extended): boolean; Var. I: integer; Begin. I := p - 1; Repeat i := i - 1 until (i <= 0) or (s[i] = '#'); Margin := i; Try. Value := StrToFloat(copy(s, i + 1, p - i - 2)); Result := true; Except. Result := false. End; Delete(s, i, p - i); End; Function FindRightValue(p: integer; var Value: extended): boolean; Var. I: integer; Begin. I := p + 1; Repeat i := i + 1 until (i > Length(s)) or (s[i] = '#'); I := i - 1; S1 := copy(s, p + 2, i - p - 1); Result := TextToFloat(PChar(s1), value, fvExtended); Delete(s, p + 1, i - p + 1); End; Procedure PutValue(p: integer; NewValue: extended); Begin. Insert('#' + FloatToStr(v1) + '#', s, p); End; Begin. Result := false; S := st; // (). P := pos('(', s); While p > 0 do begin. I := p; J := 1; Repeat. I := i + 1; If s[i] = '(' then j := j + 1; If s[i] = ')' then j := j - 1; Until (i > Length(s)) or (j <= 0); If i > Length(s) then s := s + ')'; If Recogn(copy(s, p + 1, i - p - 1), v1) = false then Exit; Delete(s, p, i - p + 1); PutValue(p, v1); P := pos('(', s); End; // sin, cos, tg, ctg, arcsin, arccos, arctg, abs, ln, lg, log, exp. Repeat. Func := fNone; P1 := pos('sin', s); If p1 > 0 then begin. Func := fSin; P := p1; End; P1 := pos('cos', s); If p1 > 0 then begin. Func := fCos; P := p1; End; P1 := pos('tg', s); If p1 > 0 then begin. Func := fTg; P := p1; End; P1 := pos('ctg', s); If p1 > 0 then begin. Func := fCtg; P := p1; End; P1 := pos('arcsin', s); If p1 > 0 then begin. Func := fArcsin; P := p1; End; P1 := pos('arccos', s); If p1 > 0 then begin. Func := fArccos; P := p1; End; P1 := pos('arctg', s); If p1 > 0 then begin. Func := fArctg; P := p1; End; P1 := pos('abs', s); If p1 > 0 then begin. Func := fAbs; P := p1; End; P1 := pos('ln', s); If p1 > 0 then begin. Func := fLn; P := p1; End; P1 := pos('lg', s); If p1 > 0 then begin. Func := fLg; P := p1; End; P1 := pos('exp', s); If p1 > 0 then begin. Func := fExp; P := p1; End; If func = fNone then break; Case func of. FSin, fCos, fCtg, fAbs, fExp: i := p + 2; FArctg: i := p + 4; FArcsin, fArccos: i := p + 5; Else i := p + 1; End; If FindRightValue(i, v1) = false then Exit; Delete(s, p, i - p + 1); Case func of. FSin: v1 := sin(v1); FCos: v1 := cos(v1); FTg: begin. If abs(cos(v1)) < pogr then Exit; V1 := sin(v1) / cos(v1); End; FCtg: begin. If abs(sin(v1)) < pogr then Exit; V1 := cos(v1) / sin(v1); End; FArcsin: begin. If Abs(v1) > 1 then Exit; V1 := arcsin(v1); End; FArccos: begin. If abs(v1) > 1 then Exit; V1 := arccos(v1); End; FArctg: v1 := arctan(v1); FAbs: v1 := abs(v1); FLn: begin. If v1 < pogr then Exit; V1 := Ln(v1); End; FLg: begin. If v1 < 0 then Exit; V1 := Log10(v1); End; FExp: v1 := exp(v1); End; PutValue(p, v1); Until func = fNone; // power. P := pos('^', s); While p > 0 do begin. If FindRightValue(p, v2) = false then Exit; If FindLeftValue(p, i, v1) = false then Exit; If (v1 < 0) and (abs(Frac(v2)) > pogr) then Exit; If (abs(v1) < pogr) and (v2 < 0) then Exit; Delete(s, i, 1); V1 := Power(v1, v2); PutValue(i, v1); P := pos('^', s); End; // *, / P := pos('*', s); P1 := pos('/', s); If (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1; While p > 0 do begin. If FindRightValue(p, v2) = false then Exit; If FindLeftValue(p, i, v1) = false then Exit; If s[i] = '*' Then v1 := v1 * v2. Else begin. If abs(v2) < pogr then Exit; V1 := v1 / v2; End; Delete(s, i, 1); PutValue(i, v1); P := pos('*', s); P1 := pos('/', s); If (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1; End; // +, - Num := 0; Repeat. Sign := 1; While (Length(s) > 0) and (s[1] <> '#') do begin. If s[1] = '-' then Sign := -Sign. Else if s[1] <> '+' then Exit; Delete(s, 1, 1); End; If FindRightValue(0, v1) = false then Exit; If Sign < 0. Then Num := Num - v1. Else Num := Num + v1; Until Length(s) <= 0; Result := true; End; End.
Могу ли я использовать в программе скрипт с Дельфи синтаксисом.
Да. В JVCL есть компонент Interpreter который позволяет выполнять скрипты написанные на Дельфи.
©Drkb::00334.
Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).
| Ловушки в Windows. |
Для отслеживания каких-то событий во всей Windows нужно установить ловушку (hook). Например, такая ловушка может отслеживать все события, связанные с мышью, где бы ни находился курсор. Можно отслеживать и события клавиатуры.
Для ловушки нужна функция, которая, после установки ловушки при помощи SetWindowsHookEx, будет вызываться при каждом нужном событии. Эта функция получает всю информацию о событии. UnhookWindowsHookEx уничтожает ловушку.
Эта программа отслеживает все сообщения, связанные с мышью и клавиатурой. CheckBox1 показывает состояние левой клавиши мыши, CheckBox2 показывает состояние правой клавиши мыши, а CheckBox3 показывает, нажата ли какая-либо клавиша на клавиатуре.
Code: Var. HookHandle: hHook; Function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall; Var. Msg: PEVENTMSG; Begin. If Code >= 0 then begin. Result := 0; Msg := Pointer(LParam); With Form1 do. Case msg.message of. WM_MOUSEMOVE: Caption := IntToStr(msg.ParamL) + #32 + IntToStr(msg.ParamH); WM_LBUTTONDOWN: CheckBox1.Checked := true; WM_LBUTTONUP: CheckBox1.Checked := false; WM_RBUTTONDOWN: CheckBox2.Checked := true; WM_RBUTTONUP: CheckBox2.Checked := false; WM_KEYUP: CheckBox3.Checked := false; WM_KEYDOWN: CheckBox3.Checked := true; End; End else. Result := CallNextHookEx(HookHandle, code, WParam, LParam); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Form1.FormStyle := fsStayOnTop; CheckBox1.Enabled := false; CheckBox1.Caption := 'left button'; CheckBox2.Enabled := false; CheckBox2.Caption := 'right button'; CheckBox3.Enabled := false; CheckBox3.Caption := 'keyboard'; HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @HookProc, HInstance, 0); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. If HookHandle <> 0 then. UnhookWindowsHookEx(HookHandle); End;
Прокрутка ListView.
Существует довольно удобный способ прокрутки списков: если пользователь водит курсором мыши по элементам списка с нажатой левой кнопкой, то выделяется тот элемент, над которым находится курсор. А если курсор оказывается выше или ниже списка, то начинается прокрутка. О том, как такое сделать для ListView, мы сегодня и поговорим.
Во-первых, нужно сделать выделение элементов, над которыми находится курсор мыши (при нажатой левой кнопке). Для нахождения элемента по координатам курсора удобно использовать функцию GetItemAt. Чтобы сменить выделение, нужно изменить свойства Selected и ItemFocused.
Чтобы отлавливать события мыши при выходе курсора за границы ListView нужно "сказать" WIndows, что мышь сейчас "моя". Для этого используется функция SetCapture (чтобы сказать, что "мышь мне больше не нужна", используется функцией ReleaseCapture). Поскольку GetItemAt в случае выхода курсора за границы ListView возвращает пустой элемент (nil), дополнительно этот случай можно не проверять. Переменная d принимает положительное значение, если прокрутка будет происходить вниз и отрицательное в противном случае. Модуль d указывает на то, сколько элементов за раз будет прокручиваться. Нужно это для изменения скорости прокрутки (здесь скорость прокрутки зависит от того, насколько далеко находится курсор от ListView).
Сама прокрутка осуществляется в процедуре Move. К номеру выделенного элемента прибавляется d. Если новый номер выходит за рамки допустимого значения, он устанавливается в 0 или Items.Count - 1. Далее происходит проверка: если номер выделенного элемента совпадает в новым номером, то делать ничего не нужно. В противном случае нужно изменить значение Selected и ItemFocused, а также прокрутить список. Для последнего удобно использовать процедуру MakeVisible. Она прокручивает список так, чтобы указанный элемент оказался видным.
Чтобы список мог прокручиваться при неподвижной мыши, нужно сделать Timer, который бы периодически вызывал Move. Если курсор снова оказывается над ListView или пользователь отпускает левую кнопку мыши, Timer выключается.
Code: Var. D: integer = 0; Procedure Move; Var. NewIndex: integer; Begin. With Form1.ListView1 do if Assigned(Selected) then begin. NewIndex := Selected.Index + d; If NewIndex < 0. Then NewIndex := 0. Else if NewIndex >= Items.Count. Then NewIndex := Items.Count - 1; If NewIndex <> Selected.Index then begin. Selected := Items[NewIndex]; ItemFocused := Selected; Selected.MakeVisible(true); End; End; End; Procedure TForm1.FormCreate(Sender: TObject); Var. I: integer; Li: TListitem; Lc: TListColumn; Begin. Timer1.Interval := 100; ListView1.ViewStyle := vsReport; Lc := ListView1.Columns.Add; Lc.Caption := 'Caption'; Lc.AutoSize := true; Lc := ListView1.Columns.Add; Lc.Caption := 'SubItem'; Lc.AutoSize := true; ListView1.Items.BeginUpdate; For i := 1 to 1000 do begin. Li := ListView1.Items.Add; Li.Caption := 'Item ' + IntToStr(i); Li.SubItems.Add('SubItem ' + IntToStr(i)); End; ListView1.Items.EndUpdate; End; Procedure TForm1.ListView1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. SetCapture(ListView1.Handle); End; Procedure TForm1.ListView1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Var. Li: TListItem; Begin. If ssLeft in Shift then with ListView1 do begin. Li := GetItemAt(10, Y); If Assigned(li) then begin. Timer1.Enabled := false; Selected := li; ItemFocused := ListView1.Selected; End else begin. If Y >= ListView1.ClientHeight. Then d := (Y - ListView1.ClientHeight) div 20 + 1. Else d := Y div 20 - 1; If Timer1.Enabled = false then begin. Move; Timer1.Enabled := true; End; End; End; End; Procedure TForm1.ListView1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. Timer1.Enabled := false; ReleaseCapture; End; Procedure TForm1.Timer1Timer(Sender: TObject); Begin. Move; End;
©Drkb::00665.
| Подсказка при вводе в Edit. |
Сегодня поговорим о том, как помочь пользователю ввести в поле ввода текст. Для этого компьютер должен по первым буквам вводимого слова догадаться, что хочет написать пользователь, и предложить ему этот вариант. Один из способов это сделать - дописывать не хватающие буквы к слову, но выделять их.
Нужно решить три задачи:
1. определить вводимые символы,
2. найти слово, начинающееся с этих символов,
3. добавить не хватающие символы и выделить их.
Для решения первой задачи достаточно найти первый символ, не являющийся буквой. Для решения второй задачи можно использовать поиск в StringList. Вставить недостающие символы удобно в специальной переменной типа String.
В этом примере словарь состоит из названий чисел (на английском): от 1 до 10. Иногда словарь можно пополнять, добавляя туда незнакомые слова, вводимые пользователем.
Code: Var. Words: TStringList; Procedure TForm1.FormCreate(Sender: TObject); Begin. Words := TStringList.Create; Words.Sorted := true; Words.Add('one'); Words.Add('two'); Words.Add('four'); Words.Add('five'); Words.Add('six'); Words.Add('seven'); Words.Add('eight'); Words.Add('nine'); Words.Add('ten'); End; Procedure TForm1.Edit1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); Const. Chars: set of char = ['A'..'Z', 'a'..'z', 'А'..'Я', 'а'..'я']; Var. W: string; I: integer; S: string; Full: string; SelSt: integer; Begin. If Key = 13 then begin. Edit1.SelStart := Edit1.SelStart + Edit1.SelLength; Edit1.SelLength := 0; Exit; End; S := Edit1.Text; SelSt := Edit1.SelStart; I := SelSt; If (length(s) > i) and (s[i+1] in chars) then Exit; W := ''; While (i >= 1) and (s[i] in chars) do begin. W := s[i] + w; Dec(i); End; If length(w) <= 0 then Exit; Words.Find(w, i); If (i >= 0) and (UpperCase(copy(words[i], 1, length(w))) = UpperCase(w)) then begin. Full := words[i]; Insert(copy(full, length(w) + 1, length(full)), s, SelSt + 1); Edit1.Text := s; Edit1.SelStart := SelSt; Edit1.SelLength := length(full) - length(w); End; End;
| Об ускорении работы с графикой. |
Сегодня поговорим о том, как по-другому можно ускорить работу с графикой.
Иногда нужные точки изображения не находятся в одной строке, например, при повороте. Для увеличения скорости в этом случае выгодно поместить всю картинку в доступную память. Для этого используется функция GetDIB. Она копирует изображение в выделенную для этого память. А дальше, чтобы узнать цвет точки (x,y) изображения WxH нужно воспользоваться следующей "формулой":
PRGBTriple(integer(p) + (H - y - 1) * (3 * W + dw) + x * 3)^
Эта "формула" возвращает цвет в формате TRGBTriple. TRGBTriple - это запись с тремя полями: красная, зеленая и синяя составляющие цвета. dw - это.
W mod 4.
И нужен он для того, чтобы создавать сдвиг, связанный с шириной изображения.
Эта программа "размывает" изображение, просто находя среднее арифметическое для каждой составляющей цвета близлежащих точек. При нажатии на Button1 изображение "размывается" с использованием GetDIB, а при нажатии на Button2 используется свойство Pixels. Время работы алгоритма в миллисекундах выводится в заголовок окна.
Code: Const. D = 5; Procedure TForm1.Button1Click(Sender: TObject); Type. PRGBTripleArray = ^TRGBTripleArray; TRGBTripleArray = array [0..0] of TRGBTriple; Var. Bi: PBitmapInfo; InfoSize, ImageSize: cardinal; BmS, bmD: TBitmap; P: pointer; Line: PRGBTripleArray; T: cardinal; R, g, b: integer; W, h, x, y, x1, y1: integer; Left, right, top, bottom: integer; Dw, norm: integer; Begin. BmS := TBitmap.Create; BmS.LoadFromFile('ex.bmp'); BmS.PixelFormat := pf24bit; W := bmS.Width; h := bmS.Height; BmD := TBitmap.Create; BmD.Width := w; bmD.Height := h; BmD.PixelFormat := pf24bit; T := GetTickCount; Dw := w mod 4; GetDIBSizes(bmS.Handle, InfoSize, ImageSize); GetMem(p, ImageSize); GetMem(bi, InfoSize); GetDIB(bmS.Handle, 0, bi^, p^); For y := 0 to h - 1 do begin. Line := bmD.ScanLine[y]; If y > d then top := y - d else top := 0; If y + d < h - 1 then bottom := y + d else bottom := h - 1; For x := 0 to w - 1 do begin. R := 0; g := 0; b := 0; If x > d then left := x - d else left := 0; If x + d < w - 1 then right := x + d else right := w - 1; For y1 := top to bottom do. For x1 := left to right do with PRGBTriple(integer(p) + (h - y1 - 1) * (3 * w + dw) + x1 * 3)^ do begin. R := r + rgbtRed; G := g + rgbtGreen; B := b + rgbtBlue; End; Norm := (bottom - top + 1) * (right - left + 1); With line^[x] do begin. RgbtRed := r div norm; RgbtGreen := g div norm; RgbtBlue := b div norm; End; End; End; Form1.Caption := IntToStr(GetTickCount - t); Form1.Canvas.Draw(0, 0, bmS); Form1.Canvas.Draw(0, h + 5, bmD); BmS.Destroy; bmD.Destroy; FreeMem(p, ImageSize); FreeMem(bi, InfoSize); End; Procedure TForm1.Button2Click(Sender: TObject); Type. PRGBTripleArray = ^TRGBTripleArray; TRGBTripleArray = array [0..0] of TRGBTriple; Var. BmS, bmD: TBitmap; T: cardinal; R, g, b: integer; W, h, x, y, x1, y1: integer; Left, right, top, bottom: integer; Norm: integer; C: TColor; Begin. BmS := TBitmap.Create; BmS.LoadFromFile('ex.bmp'); BmS.PixelFormat := pf24bit; W := bmS.Width; h := bmS.Height; BmD := TBitmap.Create; BmD.Width := w; bmD.Height := h; BmD.PixelFormat := pf24bit; T := GetTickCount; For y := 0 to h - 1 do begin. If y > d then top := y - d else top := 0; If y + d < h - 1 then bottom := y + d else bottom := h - 1; For x := 0 to w - 1 do begin. R := 0; g := 0; b := 0; If x > d then left := x - d else left := 0; If x + d < w - 1 then right := x + d else right := w - 1; For y1 := top to bottom do. For x1 := left to right do begin. C := bmS.Canvas.Pixels[x1,y1]; R := r + GetRValue(c); G := g + GetGValue(c); B := b + GetBValue(c); End; Norm := (bottom - top + 1) * (right - left + 1); BmD.Canvas.Pixels[x,y] := rgb(r div norm, g div norm, b div norm); End; End; Form1.Caption := IntToStr(GetTickCount - t); Form1.Canvas.Draw(0, 0, bmS); Form1.Canvas.Draw(0, h + 5, bmD); BmS.Destroy; bmD.Destroy; End;
| Дерево каталогов. |
Сегодня поговорим о том, как при помощи TreeView сделать дерево каталогов, то есть нечто, вроде левой части Проводника. Самый простой способ - это при запуске программы найти все каталоги на диске и засунуть их в TreeView. Но у этого способа есть несколько недостатков. Во-первых, он долгий, особенно, если включен zif. Во-вторых, даже если закрыть и открыть какую-то папку, она не обновится. Поэтому лучше всего вначале сделать в TreeView список дисков со значком "+", то есть указать, что на диске есть каталоги. Это не всегда верно, но проверять, правда ли это, долго из-за дисковода. При попытке раскрыть каталог или диск программа ищет подкаталоги и добавляет их в ListView. В каждом подкаталоге программа пытается найти хотя бы один подкаталог. В зависимости от результатов поиска "+" появляется или нет.
В этой программе используются иконки из файла FileCtrl.res, находящемся в каталоге "Delphi5\lib".
Implementation.
Code: {$R *.DFM}. {$R FileCtrl}. Procedure NextLevel(ParentNode: TTreeNode); Function DirectoryName(name: string): boolean; Begin. Result := (name <> '.') and (name <> '..'); End; Var. Sr, srChild: TSearchRec; Node: TTreeNode; Path: string; Begin. Node := ParentNode; Path := ''; Repeat. Path := node.Text + '\' + path; Node := node.Parent; Until node = nil; If FindFirst(path + '*.*', faDirectory, sr) = 0 then begin. Repeat. If (sr.Attr and faDirectory <> 0) and DirectoryName(sr.Name) then begin. Node := Form1.TreeView1.Items.AddChild(ParentNode, sr.Name); Node.ImageIndex := 0; Node.SelectedIndex := 1; Node.HasChildren := false; If FindFirst(path + sr.Name + '\*.*', faDirectory, srChild) = 0 then begin. Repeat. If (srChild.Attr and faDirectory <> 0) and DirectoryName(srChild.Name). Then node.HasChildren := true; Until (FindNext(srChild) <> 0) or node.HasChildren; End; FindClose(srChild); End; Until FindNext(sr) <> 0; End else ParentNode.HasChildren := false; FindClose(sr); End; Procedure TForm1.FormCreate(Sender: TObject); Const. IconNames: array [0..6] of string = ('CLOSEDFOLDER', 'OPENFOLDER', 'FLOPPY', 'HARD', 'NETWORK', 'CDROM', 'RAM'); Var. C: char; S: string; Node: TTreeNode; DriveType: integer; Bm, mask: TBitmap; I: integer; Begin. TreeView1.Items.BeginUpdate; TreeView1.Images := TImageList.CreateSize(16, 16); Bm := TBitmap.Create; Mask := TBitmap.Create; For i := low(IconNames) to high(IconNames) do begin. Bm.Handle := LoadBitmap(HInstance, PChar(IconNames[i])); Bm.Width := 16; Bm.Height := 16; Mask.Assign(bm); Mask.Mask(clBlue); TreeView1.Images.Add(bm, mask); End; For c := 'A' to 'Z' do begin. S := c + ':'; DriveType := GetDriveType(PChar(s)); If DriveType = 1 then continue; Node := Form1.TreeView1.Items.AddChild(nil, s); Case DriveType of. DRIVE_REMOVABLE: node.ImageIndex := 2; DRIVE_FIXED: node.ImageIndex := 3; DRIVE_REMOTE: node.ImageIndex := 4; DRIVE_CDROM: node.ImageIndex := 5; Else node.ImageIndex := 6; End; Node.SelectedIndex := node.ImageIndex; Node.HasChildren := true; End; TreeView1.Items.EndUpdate; End; Procedure TForm1.TreeView1Expanding(Sender: TObject; Node: TTreeNode; Var AllowExpansion: Boolean); Begin. TreeView1.Items.BeginUpdate; Node.DeleteChildren; NextLevel(node); TreeView1.Items.EndUpdate; End;
Информация о дисках.
Часть информации о диске можно получить при помощи функции GetVolumeInformation. Она позволяет узнать метку, тип файловой системы, серийный номер, максимальную длину имен файлов, а также несколько параметров, связанных с регистром букв в именах файлов, сжатием информации и др.
Для определения типа диска используется функция GetDriveType. Для определения объема диска и свободного пространства - GetDiskFreeSpaceEx. Для определения размера кластера и сектора можно использовать GetDiskFreeSpace. Здесь это не используется.
Code: Procedure TForm1.Button1Click(Sender: TObject); Const. Flags: array [0..5] of cardinal = ( FS_CASE_IS_PRESERVED, FS_CASE_SENSITIVE, FS_UNICODE_STORED_ON_DISK, FS_PERSISTENT_ACLS, FS_FILE_COMPRESSION, FS_VOL_IS_COMPRESSED); Var. C: char; S: string; Li: TListItem; DriveType: integer; BufLabel, bufFileSystem: array [0..1027] of char; SerialNumber, MaxFileNameLength, FileSystemFlags: cardinal; I: integer; Freeavalilable, totalspace, totalfree: int64; Procedure AddSpace(value: int64); Const onfiltered= 1024; onfiltered= 1024 * OneKB; onfiltered= 1024 * OneMB; Var. B, kb, mb, gb: integer; V: int64; S: string; Begin. Gb := value div OneGb; V := value mod OneGb; Mb := v div OneMb; V := v mod OneMb; Kb := v div OneKb; B := v mod OneKb; If gb > 0. Then s := IntToStr(gb) + ' gb' Else s := ''; If mb > 0 then s := s + ' ' + IntToStr(mb) + ' mb'; If kb > 0 then s := s + ' ' + IntToStr(kb) + ' kb'; If b > 0 then s := s + ' ' + IntToStr(b) + ' b'; If s = '' then s := '0'; Li.SubItems.Add(s); End; Begin. ListView1.Items.BeginUpdate; ListView1.Items.Clear; For c := 'A' to 'Z' do begin. S := c + ':'; DriveType := GetDriveType(PChar(s)); If DriveType = 1 then continue; Li := ListView1.Items.Add; Li.Caption := s; Case DriveType of. 0: li.SubItems.Add('unknown'); DRIVE_REMOVABLE: li.SubItems.Add('removable'); DRIVE_FIXED: li.SubItems.Add('fixed'); DRIVE_REMOTE: li.SubItems.Add('remote'); DRIVE_CDROM: li.SubItems.Add('cdrom'); DRIVE_RAMDISK: li.SubItems.Add('ramdisk'); End; If not GetVolumeInformation(PChar(s), bufLabel, sizeof(bufLabel), Addr(SerialNumber), MaxFileNameLength, FileSystemFlags, BufFileSystem, sizeof(bufFileSystem)) then continue; Li.SubItems.Add(bufLabel); Li.SubItems.Add(bufFileSystem); Li.SubItems.Add(IntToStr(SerialNumber)); Li.SubItems.Add(IntToStr(MaxFileNameLength)); For i := low(flags) to high(flags) do. If (FileSystemFlags and flags[i]) <> 0. Then li.SubItems.Add('yes'). Else li.SubItems.Add('no'); GetDiskFreeSpaceEx(PChar(s), freeavalilable, totalspace, @totalfree); AddSpace(freeavalilable); AddSpace(totalspace); AddSpace(totalfree); End; ListView1.Items.EndUpdate; End; Procedure TForm1.FormCreate(Sender: TObject); Const. FlagStrs: array [0..5] of string = ( 'Case preserved', 'Case sensitive', 'Unicode', 'Preserve ACLs', 'File Compression', 'Volume Compression'); Procedure AddColumn(caption: string); Var. Lc: TListColumn; Begin. Lc := ListView1.Columns.Add; Lc.Caption := caption; Lc.Width := ColumnHeaderWidth; End; Var. I: integer; Begin. ListView1.ViewStyle := vsReport; AddColumn('root'); AddColumn('type'); AddColumn('label'); AddColumn('file system'); AddColumn('Serial Number'); AddColumn('MaxFileNameLen'); For i := low(FlagStrs) to high(FlagStrs) do. AddColumn(FlagStrs[i]); AddColumn('FreeAvalilable'); AddColumn('TotalSpace'); AddColumn('TotalFree'); Button1.Click; End;
©Drkb::01383.
Как получить серийный номер тома жесткого диска?
Code: Procedure TForm1.Button1Click(Sender: TObject); Var. VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char; VolumeSerialNo : DWord; MaxComponentLength, FileSystemFlags : Integer; Begin. GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo, MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH); Memo1.Lines.Add('VName = '+VolumeName); Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8)); Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength)); Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4)); Memo1.Lines.Add('FSName = '+FileSystemName); End;
©Drkb::01384.
| В строке состояния TStatusBar выводится только 127 символов. |
В строке состояния TStatusBar выводится только 127 символов.
Можно ли как-нибудь увеличить это число?
Code: Procedure TForm1.Button1Click(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru}. Var i:integer; S:string; Begin. S:=''; For i:=1 to 150 do. S:=s+inttostr(i mod 10); Label1.Caption:=s; Form1.Paint; End; Procedure TForm1.FormPaint(Sender: TObject); Begin. Label1.Repaint; Application.processmessages;{yield;}. Statusbar1.Canvas.CopyRect(rect(2,round((statusbar1.height- label1.height)/2),label1.width,label1.height), Label1.canvas,rect(0,0,label1.width,label1.height)); End;
| ADO и SQL Server. Руководство разработчика. |
ADO и SQL Server. Руководство разработчика.
1. Введение.
Очевидно, что доступ к данным является важнейшим требованием при разработке современных бизнес-приложений. Технология ODBC обеспечивает доступ к реляционным базам данных и это первый шаг на пути решения этой проблемы. Однако, когда разработчики хотят включить в свои проекты нереляционные источники данных или работать в средах, подобных Интернет, они сталкиваются с дилеммой - либо разрабатывать собственные парадигмы доступа к данным, либо работать на уровне API, что несовместимо с новыми средами. ActiveX объекты доступа к данным (ADO) решают эту дилемму и обеспечивают единую модель, которая работает со всеми источниками данных в различных средах. Таким образом ADO обеспечивает последовательный, высокопроизводительный доступ к данным, с которыми вы можете создавать клиентские программы для работы с БД или бизнес-объекты среднего уровня, использующие приложения, инструментарий, язык или, даже, Интернет-смотрелку (естественно, Експлорер). ADO - это единый интерфейс доступа к данным, который вам необходим для создания одно- и многоуровневых приложений архитектуры клиент/сервер и Web-ориентированных информационных систем.
2. Обзор ADO.
Технология ADO была впервые применена в Microsoft Internet Information Server как интерфейс доступа к БД. Использование ADO позволяет минимизировать сетевой траффик в ключевых Internet-сценариях и уменьшить количество промежуточных уровней между клиентским приложением и источником данных. ADO легко использовать, так как он (или они (объекты) или она (технология)) применяет привычную систему вызовов - интерфейс Автоматизации OLE, доступный сегодня в большинстве средств разработки приложений. Из-за легкости применения и изучения популярность ADO будет расти и в итоге ADO вытеснит технологии RDO и DAO, которые в настоящее время применяются очень широко. Технология ADO во многом подобна RDO и DAO, например, она использует те же соглашения языка. ADO также поддерживает аналогичную семантику и поэтому может быть легко освоена разработчиками ПО.
ADO является интерфейсом программного уровня к OLE DB, новейшей и мощнейшей (сильно сказано) парадигме доступа к данным от MS. OLE DB обеспечивает высокопроизводительный доступ ко многим источникам данных. ADO и OLE DB вместе представляют собой основу стратегии Универсального доступа к данным (Universal Data Access). OLE DB дает возможность универсального доступа ко многим данным и представляет разработчикам возможность сделать это достаточно легко. Так как ADO находится на вершине OLE DB, то применение ADO имеет все преемущества Универсального доступа к данным, которое обеспечивает OLE DB.
3. Обзор OLE DB.
OLE DB - это открытая спецификация, разработанная на основе успеха спецификации ODBC и обеспечивает открытый стандарт доступа ко всем видам данным в системах масштаба предприятия. OLE DB - это ядро технологии поддерживающей Универсальный доступ к данным. В отличие от технологии ODBC, которая была создана для доступа к реляционным БД, технология OLE DB разработана для реляционных и нереляционных источников данных, таких как хранилища почты (mail stores), текстов и графики для Web, службы каталогов (directory services), IMS и VSAM хранилищ данных на мэйнфреймах.
Компоненты OLE DB состоят из провайдеров данных (data providers), которые представляют свои данные, потребителей данных (data consumers), которые используют данные, и сервисных компонент (service components), которые обрабатывают и транспортируют данные (например, процессор запросов и механизм курсоров). OLE DB включает в себя мост с ODBC, чтобы дать возможность разработчикам использовать ODBC-драйвера реляционных БД, широко распространенные в настоящее время.
OLE DB провайдеры.
Существует два типа OLE DB приложений: потребители и провайдеры. Потребителями могут быть любые приложения, которые используют OLE DB интерфейсы. Например, Visual C++ приложение, которое использует OLE DB интерфейсы для связи с сервером БД - это OLE DB потребитель. Объектная модель ADO, которое использует OLE DB интерфейсы, - это тоже OLE DB потребитель. Любое приложение, которое использует ADO, косвенно использует OLE DB интерфейсы через объекты ADO.
OLE DB провайдер осуществляет OLE DB интерфейсы, поэтому, OLE DB провайдер дает возможность потребителям иметь доступ к данным единообразным способом через ряд документированных интерфейсов. В этом смысле OLE DB провайдер подобен ODBC драйверу, который обеспечивает универсальный механизм доступа к реляционным БД, но только для нереляционных типов данных. Более того, OLE DB провайдер встроен в вершину OLE COM интерфейсов, что придает ему большую гибкость, а ODBC драйвер встроен в вершину C API спецификации.
Microsoft OLE DB SDK version 1.1 поставляет два OLE DB провайдера: ODBC провайдер и провайдер текстов. Провайдер текстов служит примером, который демонстрирует подробную реализацию OLE DB провайдера. ODBC провайдер - это OLE DB провайдер для ODBC драйверов. Этот провайдер предоставляет механизм для потребителей, чтобы использовать существующие ODBC драйверы без необходимости срочной замены существующих ODBC драйверов на новые OLE DB провайдеры. Больше информации про OLE DB и OLE DB провайдеры можно посмотреть на http://www.microsoft.com/data в разделе OLE DB.
ODBC Провайдеры.
ODBC провадер устанавливает соответствие между OLE DB интерфейсами и ODBC API. С ODBC провадером OLE DB потребители могут связываться с сервером БД через существующие ODBC драйверы. Потребитель вызывает OLE DB интерфейс через ODBC провайдера. ODBC провайдер вазывает соответствующие ODBC API иннтерфейсы и посылает запросы к ODBC драйверу. Целью разработки ODBC провайдера является осуществление всей функциональности менеджера ODBC драйвера. Поэтому теперь нет необходимости в менеджере ODBC драйвера. Однако при использовании ODBC провайдером версии 1.1 менеджер ODBC драйвера все еще требуется для поддержки связи с ODBC приложениями.
4. Объектная модель ADO.
Объектная модель ADO определяет набор (коллекцию) программируемых объектов, которые могут использоваться с Visual Basic, Visual C++, VBScripting, Java на любой платформе, которая поддерживает COM и Автоматизацию OLE. Объектная модель ADO разработана для выполнения большинства особенностей OLE DB.
ADO содержит семь объектов:
* Connection.
* Command.
* Parameter.
* Recordset.
* Field.
* Property.
* Eror.
И четыре набора объектов (коллекции):
* Fields.
* Properties.
* Parameters.
* Errors.
Коллекция Properties и объект Property доступны через объекты Connection, Recordset и Command. Коллекция Properties и объект Property содержат свойства, которые могут быть доступны только для чтения или для чтения-записи.
Объекты Connection, Recordset и Command являются ключевыми объектами в объектной модели ADO. ADO приложение может использовать объект Connection для установки соединения с сервером БД, объект Command - для выдаче команды к БД, таких как запросы, обновления и т.п. и объект Recordset - для просмотра и манипулирования данными. Командный язык, используемый с объектом Command, зависит от провайдера для БД. В случае реляционных баз данных в качестве командного языка выступает SQL.
Объект Command может не использоваться в случае, если OLE DB провайдер не обеспечивает выполнение интерфейса Icommand. Как как OLE DB провайдер может находиться на вершине реляционных или нереляционных БД, то традиционные SQL-операторы для запроса данных могут быть недоступны для нереляционной БД и поэтому объект Command не потребуется. Если объект Command содержит параметры, то информацию о них можно просмотреть или определить через набор объектов Parameters и объект Parameter. Объект Parameter описывает информацию о параметрах для объекта Command.
В ADO версий 1.0 и 1.5 все объекты могут быть созданы, за исключением объектов Error, Field и Property. К набору объектов Errors и объекту Error можно получить доступ через объект Connection после того как случилась ошибка провайдера. К набору объектов Fields и объекту Field можно получить доступ через объект Recordset после того как в объекте Recordset появятся какие-либо данные. Информация о метаданных объекта Recordset может быть просмотрена через набор объектов Fields и объект Field.
5. Объект Connection.
Объект Connection позволяет установливать сеансы связи с источниками данных. Объект Connection обеспечивает механизм для инициализации и установления соединения, выполнения запросов и использования транкзаций.
Основной OLE DB провайдер, используемый для соединения, не ограничивает использование других ODBC провайдеров. Другие провайдеры так же могут использоваться для соединения. Провайдер определяется посредством установки свойства Provider. Если это свойство не определено, то по умолчанию будет использован провайдер MSDASQL.
Метод Open объекта Connection используется для установки соединения. С ODBC провайдером, приложение ADO может использовать механизм ODBC соединения для подключения к серверу БД. ODBC позволяет приложениям устанавливать соединение через источники данных ODBC или явно определять источник данных (DSN-Less connection).
Перед соединением приложение может установить строку соединения, тайм-аут соединения, БД по умолчанию и атрибуты соединения. Объект Connection так же позволяет установить свойство CommandTimeout для всех командных объектов, связвнных с данным соединением. Запросы могу выполняться с использованием метода Execute.
Через объект Connection можно управлять транкзациями. Для этого у него есть методы BeginTrans, CommitTrans и RollbackTrans.
Следующий пример показывает использование ODBC провайдера - по умолчанию OLE DB провайдера в ADO, для подсоединения к SQL Server:
Code: Dim Cn As New ADODB.Connection. Cn.ConnectionTimeout = 100. ' DSN connection. #Cn.Open "pubs", "sa". ' DSN-Less connection for SQL Server. ' Cn.Open 'Driver={SQL Server};Server=Server1;Uid=sa;Pwd=;Database=pubs' Cn.Close.
| ProgressBar, который не отображают реального прогресса. |
Начиная с виньХР появились в системе забавные РrоgrеssВаr'ы, которые не отображают реального "прогресса", а лишь отображают, что что-нибудь работает... такой же появляется при загрузки виндыХР (бегает пару чёрточек слева вправо, а потом обратно возвращаются в начало). Такой же прогресс отображается если в ХР выбрать изображение, в меню нажать на Print (Печать), и вэтом диалоге при выборе шаблона печати - тоже такого стиля есть прогресс. (надеюсь, что теперь ясно что я имел в виду ).
И сам вопрос: как такой сделать на делфи?
Судя по MSDN, надо.
Code: {©Drkb v.3(2007): www.drkb.ru}. Const. PBS_MARQUEE = $08; PBM_SETMARQUEE = WM_USER+10; ... With ProgressBar1 do. Begin. SetWindowLong (Handle, GWL_STYLE, (GetWindowLong (Handle, GWL_STYLE) or PBS_MARQUEE)); Perform(PBM_SETMARQUEE, 1, 50); End;
| Запустить приложение и подождать. |
Code: Function ExecuteFile(FileName, Params, WorkingDir:string; Wait:boolean):integer; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Var. Buffer: array[0..511] of Char; TmpStr: String; I: Integer; StartupInfo:TStartupInfo; ProcessInfo:TProcessInformation; Ext, key, fname, path:string; Exitcode:cardinal; Begin. If WorkingDir<>'' then ChDir(WorkingDir); Ext:=lowercase(ExtractFileExt(FileName)); Path:=ExtractFilePath(FileName); If ext<>'.exe' then. With TRegistry.create do. Try. RootKey:=HKEY_CLASSES_ROOT; OpenKey(ext, false); Key:=ReadString(''); CloseKey; OpenKey(key+'\Shell\open\command', false); Key:=ReadString(''); Fname:=ExtractFileName(key); If pos('/', fname)>0 then fname:=copy(fname,1, pos('/',fname)-1); FName:=StringReplace(FName, '%1', '', [rfReplaceAll, rfIgnoreCase]); If pos(' ',FileName)>0 then FileName:='"'+Filename+'"'; TmpStr:=ExtractFilePath(key)+Fname+' '+FileName; If Params<>'' then TmpStr := TmpStr + ' ' + Params; Closekey; Finally. Free; End. Else. Begin. TmpStr := FileName; TmpStr := TmpStr + ' ' + Params; End; StrPCopy(buffer,TmpStr); FillChar(StartupInfo,Sizeof(StartupInfo),#0); StartupInfo.cb := Sizeof(StartupInfo); StartupInfo.dwFlags := STARTF_USESHOWWINDOW; StartupInfo.wShowWindow := SW_SHOWNORMAL; If CreateProcess(nil, buffer, nil, nil, false, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then. Begin. If Wait then. Begin. While WaitforSingleObject(ProcessInfo.hProcess,200)=WAIT_TIMEOUT do application.ProcessMessages; GetExitCodeProcess(ProcessInfo.hProcess, exitcode); End; End. Else. Result := GetLastError(); End;
Как сделать так, чтобы в компонент TEdit можно было вводить текст только на английской раскладке?
Когда TEdit получает фокус надо вызвать:
Code: ActivateKeyboardLayout($409, 0);
Если этого мало тогда почитай про WM_INPUTLANGCHANGE.
Автор: cully.
©Drkb::00541.
Взято с Vingrad.ru http://forum.vingrad.ru.
| Узнать класс формы. |
Code: Type. PFieldClassTable = ^TFieldClassTable; TFieldClassTable = packed record. Count: Smallint; Classes: array[0..8191] of ^TPersistentClass; End; Function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler; Asm. MOV EAX,[EAX].vmtFieldTable. OR EAX,EAX. JE @@1. MOV EAX,[EAX+2].Integer. @@1: End; Procedure TForm1.Button1Click(Sender: TObject); Procedure Display( const S: String ); Begin. Memo1.lines.add( S ); End; Var. PFCT: PFieldClassTable; AClass: TClass; I: SmallInt; Begin. Memo1.clear; AClass:= Classtype; While aClass <> TPersistent Do Begin. Display('Registered classes for class '+aClass.Classname ); PFCT := GetFieldClasstable( aClass ); If not Assigned( pFCT ) Then. Display(' No classes registered'). Else Begin. Display( format(' %d classes registered', [pFCT^.Count])); For i:= 0 to pFCT^.Count -1 do. Display( ' '+pFCT^.Classes[i]^.ClassName ); End; AClass := aClass.ClassParent; End. End;
| Написание программ на чистом WinAPI. |
Написание программ на чистом WinAPI.
Попробуем написать с Вами программу, которая не будет пользоваться VCL, а будет использовать вызовы функций Windows API.
Приложения такого типа нужны, когда размер исполняемого файла является критичным. Например, в инсталяторах, деинсталяторах, самораспаковывающихся архивах и т.п. В крайнем случае, для того чтобы посмотреть какую работу выполняет за нас VCL, и что из себя представляет Windows-программа.
На самом деле все очень просто...
Для этого нам необходимо:
1. Зарегистрировать класс окна для окна главной формы.
Code: Function InitApplication: Boolean; Var. Wcx: TWndClass; Begin. //Заполняем структуру TWndClass. // перерисовываем, если размер изменяется. Wcx.style := CS_HREDRAW or CS_VREDRAW; // адрес оконной процедуры. Wcx.lpfnWndProc := @MainWndProc; Wcx.cbClsExtra := 0; Wcx.cbWndExtra := 0; // handle to instance. Wcx.hInstance := hInstance; // загружаем стандандартную иконку. Wcx.hIcon := LoadIcon(0, IDI_APPLICATION); // загружаем стандартный курсор. Wcx.hCursor := LoadCursor(0, IDC_ARROW); // делаем светло-серый фон. Wcx.hbrBackground := COLOR_WINDOW; // пока нет главного меню. Wcx.lpszMenuName := nil; // имя класса окна. Wcx.lpszClassName := PChar(WinName); // Регистрируем наш класс окна. Result := RegisterClass(wcx) <> 0; End;
| Создание отчетов с помощью QuickReport 3 (статья). |
Создание отчетов с помощью.
QuickReport 3.
Что такое QuickReport 3?
QuickReport 3 это набор компонент для Delphi позволяющий вам построить отчет из базы данных быстро и просто. Позволяет не только отпечатать отчет, но и просмотреть его на экране, что позволяет пользователю проверить результат без порчи бумаги и экспортировать отчет в другие форматы, такие как простой ASCII текст, текст разделенный запятыми (CSV) и в HTML.
QuickReport сам написан на Delphi и знает все про модель Delphi обработки баз данных. Поэтому вы можете для создания отчетов в традиционных базах данных, базирующихся на BDE, таких как Paradox и dBase, клиентских наборов данных используемых в многоуровневой среде (multi-tier), новое для Delphi 5 ADO и Interbase Express components, так же альтернативные движки третьих сторон, такие как Apollo. Вы можете использовать QuickReport и для печати данных не из баз, если в этом есть потребность.
Данное руководство разработано для того, что бы быстрее освоить QuickReport, так что вы можете немедленно начать использовать его в ваших приложениях.
А также.
QuickReport это прекрасный продукт, но если вам нужны расширенные возможности, то вы можете их расширить с помощью QuickReport Pro. В версию Pro включено все, что имеется в обычной версии плюс:
· Три дополнительных фильтра:
1. Excel XLS: XLS фильтр совместим с версией Excel 4 и позже, и предоставляет простой и надежный механизм для экспортирования данных в электронную таблицу.
2. Rich Text RTF: RTF фильтр базируется на спецификации Microsoft RTF версии 1.5, поддерживает больше возможностей, чем TRichEdit.
3. Windows Metafile WMF: WMF фильтр позволяет сохранить отчет в мета графическом формате.
· Несколько дополнительных компонент.
1. TQREditor построитель отчетов для конечного пользователя, что позволяет поставлять отчеты отдельно от программы.
2. TQuickAbstractRep наследник от базового класса TcustomQuickRep, который не использует TDataset - используйте это для построения своих собственных систем
3. TQRLoopBand печатает секцию несколько раз в зависимости от свойства PrintCount - прекрасная вещь для создания бланк форм.
4. TQRListWizard позволяет создать отчет на основе списка полей вашей таблицы
5. Прекрасная поддержка через email.
6. Полные исходные тексты. Программист может просто модифицировать код для локализации на конкретный язык, адоптировать в соответствии с требованиями локального стандарта на интерфейсы, добавить новые свойства и т.д.
7. Больше демо проектов, с углубленным качеством, включая примеры использования всех дополнительных свойств версии Pro, и дополнительная техника по написанию собственных функций для анализатора выражений.
Вы можете получить QuickReport Professional путем заполнения формы заказа на нашем web сайте, или у наших дистрибуторов QBS Software Ltd на http://www.qbss.com или у вашего локального продавца Delphi.
Первый отчет.
Наилучший путь познать QuickReport это посмотреть его в действии. Данная глава показывает, как создать очень простой отчет. Запустите Дельфи и выполните следующие шаги:
1 Выберите File | New Application.
2 Бросьте TTable компонент на главную форму.
3 С помощью Object Inspector установите свойство DatabaseName на 'DBDemos', TableName на 'CUSTOMER.DB' и Active в True.
4 Бросьте TQuickRep компонент на главную форму. Размеры и позиция не имеют никакого значения.
5 Установите свойство DataSet на 'Table1'. Это ключевой шаг. Генератор отчетов проходит по всем записям в DataSet, только в этом случае Table1, может быть распечатан или просмотрен.
6 Если необходимо, то раскройте свойство Bands в Object Inspector путем нажатия на значок +. Установите HasDetail в True. Вы увидите, как появится секция в вашем отчете; смена свойства в действительности создает DetailBand1 объект.
7 Бросьте TQRDBText компонент на вновь созданную секцию.
8 Смените свойство DataSet на 'Table1' и DataField на 'Company'.
В данный момент вы должны видеть не что подобное, изображенному на рисунке Figure 1.
Figure 1 – Setting up a basic report.
Для проверки, что вы все выполнили правильно, просмотрите отчет, для этого в любом месте TQuickRep щелкните правой кнопкой мышки и выберите Preview из меню.
Если вы видите это, то это значит, что вы создали отчет, который работает в design time. Конечно, не всегда все получается сразу. Если вы получили пустой лист, то проверьте, что выполнили все выше описанные шаги полностью – обычно забывают установить свойство TTable1.Active в значение True. Подобно если вы видите, что отчет содержит только одну строку – 'Kauai Dive Shoppe' – то проблема в том, что вы забыли связать QuickRep1 Dataset с TTable1.
Еще одна частая проблема, что вы не видите кнопок на линейке в форме просмотра. Тут никто не виноват (J): вы должны связаться с производителем операционной системы вашего компьютера и сказать 'DLL Hell'. Specifically, your machine's copy of the common control library (comctrl32.dll) is before 4.72, and needs updating. (От переводчика - замените comctrl32.dll на более свежую).
Вы также можете загрузить самую свежую версию comctrl32.dll с сайта Microsoft http://www.microsoft.com. Но поскольку данный файл входит в комплект поставки Internet Explorer и Windows Service Packs, то вы можете взять его с вашего CD. (В действительности вряд ли подобный баг вас затруднит как разработчика).
Теперь заставим данный отчет работать в откомпилированной программе. Вы должны написать код для вызова TQuickRep.Preview:
1 Разместите клавишу на вашей форме и установите ее свойство в 'Просмотр'
2 Дважды щелкните по данной кнопке, для добавления обработчика OnClick. Добавьте одну строчку кода:
Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. QuickRep1.Preview; End;
| QT: интерфейс, и не только... |
QT: интерфейс, и не только...
Если вы связаны с программированием, то наверняка уже встречали сочетание Qt. Многие (0,1%) из вас даже использовали Qt в своих разработках, пусть даже как следствие инсталляции Borland Kylix. В общем, самое время посмотреть на Qt, что называется, "в упор, двумя глазами"…
Этот продукт на слуху у всех разработчиков, которые программируют для Linux. И не только у них — например, самый модный и удобный многоплатформенный клиент для сетей AIM/ICQ (точнее, ICQ/AIM), sim, написанный питерцем Володей Шутовым, создан именно с использованием Qt. Не говоря уже о Borland Kylix — там вообще все работает поверх Qt.
Такие совпадения — там вилочка, тут ножичек — поневоле задумаешься…
Идея
Норвежская компания Trolltech AG (изначально называвшаяся Quasar Technologies, откуда, собственно, и пошла аббревиатура Qt) образовалась из двух (хм…) норвежцев, Эйрика Енга (Eirik Eng) и Хаварда Норта (Haavard Nort) с целью… короче, как всегда, с целью подрубить бабла. Но, кроме того, еще и создать пару нетленок из разряда универсальных библиотек, которые завоюют весь мир. Уж такой народ норвежцы — не могут без славы и денег.
Дело было в 1994 г. в городе Осло. Само сочетание "Qt" некоторые произносят как "кьют" ака cute — то есть "мило, прикольно". В общем-то, так оно и есть, если, конечно, вы способны оценить красоту, выраженную в терминах С++.
Говоря более конкретно, во главу угла были поставлены две вещи. Первое: библиотеки создавались для языка С++. Второе: основой всему был именно интерфейс пользователя, поскольку это самый несовместимый и позорный момент во всем софтвере — полностью разные парадигмы графического пользовательского интерфейса.
Как известно, MS Windows использует "локальный" GUI API, который, однако, недавно был транспонирован на сетевые подключения в XP Remoting. Все UNIX-like, и Linux в том числе, были изначально (ну, как изначально — как только рабочие станции доросли до графики, естественно) завязаны на X Windows, который, хоть и работает от рождения по сети, но локально показывает худшие характеристики быстродействия и реактивности из всех рассматриваемых интерфейсов. Наконец, графика Mac OS, зашитая полуаппаратно в фирменных BIOS-"тулбоксах", всегда показывала скорость и красоту, даже когда Windows еще под стол пешком ходила. Но это было: а) проприетарно, б) ни с чем не совместимо — даже приблизительно.
Короче — бардак и брожение умов. Вот прибалты и задумались…
Точнее задумались-то не только они. В качестве переносимого графического интерфейса можно использовать хоть Java, хоть Tk/Tcl, а хоть и Macromedia Flash — на последних версиях этого Flash можно писать вполне приличные приложения. Это только те "задумавшиеся", у кого получилось,— об остальных мы просто не знаем.
Да, так вот, у Trolltech тоже неплохо получилось, как именно — сейчас посмотрим.
Кю-тэшное семейство, обзор
На самом деле существует несколько продуктов Qt, хотя все они "завязаны" на одном и том же коде. Собственно Qt — это межплатформенная библиотека для С++. Более конкретно — библиотека классов, "цешники"-натуралы отдыхают. То есть это даже и библиотекой-то не назовешь — сами создатели именуют это как framework, то есть программная оболочка. Но, конечно, от этого она не перестает быть обычной библиотекой.
Применение нового "стиля" в Qt может мгновенно придать вашему приложению новый вид
Помимо переносимого интерфейса библиотека также занимается интернационализацией, то есть располагает инструментом для перевода интерфейса на ваш родной китайский язык (сделано это, кстати, очень прикольно). Менеджер релизов выкусывает из кода все строки, подлежащие переводу. Они должны быть, правда, особого формата, чтоб не было накладок с непереводимыми фразами. Короче, полученные таблицы фраз поступают в средство перевода — Linguist. Сам он ничего не переводит (это делаете вы) — но зато помогает сохранять уже переведенные фразы в словарях. Так что вы можете менять программу как вам угодно, и то, что уже переведено, уже никогда не будет требовать перевода.
Третье, что было сделано (кстати, уже по ходу разработки — по просьбе многих клиентов), это системно-независимые механизмы доступа к базам данных. Конечно, я уже не говорю о таких вещах, как унифицированный сетевой доступ, XML, трехмерная графика и так далее — просто различия в этих сферах не так разительны, как в перечисленных выше.
Выходит, что Qt — это как бы "мегапатч" к стареньким си-либам, позволяющий:
1. работать в графике;
1. переводить программы;
1. выполнять запросы к БД;
1. унифицированно реализовывать все остальное, вроде мультимедиа.
Помимо основной библиотеки, существует основанный на том же коде framework для всякой мобильной живности вроде смарт-фонов и PDA под управлением Embedded Linux (особенно засветился в этом секторе Sharp). Называется эта штуковина Qtopia. Инструмент для разработки встроенных систем с ограниченной функциональностью называется Qt/Embedded.
Далее, QSA — скриптовый язык, позволяющий управлять готовыми приложениями на Qt/C и расширять их возможности в скриптовом контексте.
Teambuilder — средство компиляции, которое собирает статистику утилизации CPU по целой рабочей группе и позволяет оптимизировать процесс сборки на менее загруженных станциях.
Ко всему, существует несколько "плугов" для известных сред разработки (говоря проще — для Visual Studio и Borland Builder), упрощающих разработку под Qt,— Qt Solutions.
В качестве визуального инструмента разработки используется Qt Designer — это "малевалка" интерфейса, подобная всем "клик-энд-го". Конечно, еще полно полезного хелпняка: просто тысячи артиклов, плюс девяносто шесть (проверьте) примеров — и это есть гуд.
Однако сосредоточимся на Qt — все остальное вторично.
Инсталл
Конечно же, сначала следует проинсталлировать систему. Под Windows нужно обратить внимание на три вещи. Во-первых, потребуется ввести имя пользователя, компанию и сериал. Вводите их точно в таком же виде, как указано в письме, которое вам придет (сериал является хеш-фанкшином от даты активации и двух остальных полей) — иначе ничего работать не будет.
Во-вторых, при инсталляции предпоследним пунктом идет установка примеров. Они приходят в виде исходных текстов, но в процессе установки будут компилироваться. Компиляция происходит в командной строке, так что без установленных переменных окружения это не сработает, получите ошибку "где линкер дел, гад?". Пофиксить проблему просто: создайте и запустите bat-файл типа:
Call "C:\Program Files\Microsoft Visual Studio .NET 2003\Common7\Tools\vsvars32.bat" qt-win-eval-msvc-3.3.3.exe.
Третья заморочка: примеры и туторы тоже так просто работать не станут. Они не могут найти свою библиотеку, хотя в переменной пути к ней все вроде и указано. На самом деле для правильной работы нужно установить переменные окружения — а они, в свою очередь, устанавливаются при загрузке профиля пользователя. Даже и перезагружаться не нужно, просто отлогоньтесь-прилогоньтесь. Кстати, о необходимости такой операции пишется в конце инсталляции — но кто же такое читает?
Если вы инсталлируетесь под Linux и BSD, то я вам ничего не стану рассказывать — сами с ушами. Скажу только, что уровень проблем при инсталляции под этой ОС может колебаться в очень больших пределах, в зависимости от поддержки вашего дистрибутива и его "комплектации" на момент установки. Я ставил на Slakware, RH и Mandrake без особых проблем. В любом случае Qt нужно ставить на KDE.
Библиотека, learning curve.
Как я уже говорил, Qt — это библиотека классов. Классов там более четырехсот, так что, если начальник требует, чтобы вы начали кодить на Qt с завтрашнего дня, то лучше послать его к ежам. Придется, как минимум, пару недель изучать доки, а лучше прочитать книжку. Я за целую ночь не смог воткнуть даже простецкие вещи. Вам тоже торопиться не советую, лучше делать все правильно — от простого к сложному.
Может быть, не первая по важности, но несомненно нужная после инсталляции вещь — просмотр, распечатка, (а возможно, и татуировка на груди — вверх ногами, чтобы читать было удобно) иерархии классов Qt.
Это, в общем-то, относится к любой библиотеке. Но в некоторых "системах ценностей" вы можете прожить три жизни, и проходить при этом "в лаптях", то есть использовать 3% от всех возможностей, обходя стороной то, что, собственно, и составляет ценность продукта. Пример: множество малопонятных функций в MS Exсel, масса никому не нужных ActiveX-компонент (помните, как они продавались почти по одной штучке — во цирк!) и т.д. В Qt все несколько иначе — вы в конце концов будете использовать 50-80% всех классов, так что "отбыть номер" не удастся.
Общий вид иерархии классов Qt.
Непременно прочитайте whitepapers — в отличие от других "белок", это не просто набор рекламных лозунгов. После чтения приведенных там примеров вы даже сможете построить несколько приложений.
Как маршрут для вечерних прогулок вы должны избрать посещение сайта http://doc.trolltech.com/3.3/ — вас там многое заинтересует, начиная, конечно, с How To Learn Qt. Собственно, всегда лучше начинать с голого кодирования, не пользуясь автогенераторами — или пользуясь, но при этом тщательно разбирая код. В противном случае вы напишете что-то, что потом не сможете ни объяснить, ни поддержать, ни модифицировать.
Как оно работает
Говоря в общем, все вращается вокруг событий, называемых сигналами, и слотов — то есть регистрируемых реакций на эти события. В отличие от других "закрытых" событийных множеств (вроде тех, что встречаются в Active Script) система сигналов Qt полностью динамическая — каждый участок кода может регистрировать или обрабатывать сигналы. Это напоминает механизм, условно известный как WM_USER+1.
Сигналы имеют отдаленное отношение к системным событиям и являются их произвольной трансляцией — так же как это реализовано в Delphi. Естественно, что ни одна система не должна порождать таких шквалов нотификаций, как Windows. Обеспечивать приложению доступ к событиям неклиентской области — по-моему, большая ошибка архитекторов этой системы, породившая немало "смешных" интерфейсов.
Что касается графического интерфейса, то он более всего похож на Java Swing — тут тоже существуют схемы стилей, например Windows, CDE, Motif, копирующие известные оболочки. Присутствуют также layout’ы, автоматически размещающие элементы управления; кроме того, есть такие "пружинки", или "спейсеры", которые расталкивают сопредельные компоненты.
Есть также немало вещей, напоминающих Delphi: хинты размеров (то есть "как было бы лучше"), масштабирование компонент и прочие вещи, претендующие на красивость.
Как и в Swing, все элементы перерисованы от руки, то есть стандартные механизмы рисования элементов управления не применяются — вместо этого используется, например, GDI WinAPI. Автоматически определяется версия ОС и, соответственно, реализуются или игнорируются те или иные свойства, вроде прозрачности или XP-прибамбасов. В качестве небольшого попуска Qt использует стандартные диалоговые окна Windows, в частности диалоги открытия файла и настойки печати.
Под X11 Qt не использует тулкиты вроде Motif или Xt — ну, Qt вроде и сам такой же тулкит (то есть — зачем же?). Вместо этого напрямую используется Xlib — с расширениями вроде RENDER, если они доступны.
Схема "генеральной помпы", то есть основного цикла событий, не очень отличается от всех подобных во всех ОС — от MS Windows до PalmOS. Приложение строится просто, если не сказать примитивно: создается главное окно, устанавливаются его параметры, после чего приложение непосредственно "ранится". Вот как выглядит известный всем "Привет, мир!":
Code: #include < qapplication.h > #include < qlabel.h > Int main( int argc, char **argv ). { QApplication app( argc, argv ); QLabel *hello = new QLabel( "Привет, мир!", 0 ); App.setMainWidget( hello ); Hello->show(); Return app.exec(); }
Содержание.
- Указание языка помещенного в clipboard текста.
- Целочисленное деление.
- Учимся работать с POP3 по tе1nеtу.
- Типы.
- Управление Word-ом из Дельфи.
- Управляющий протокол SNMP.
- Что можно поместить в DBGrid.
- Что такое журнал транзакций?
- Что такое репликация?
- Что такое сообщения Windows?
- Что такое суррогатный ключ?
- Что такое триггер?
- Установка драйвера.
- Установка справки для сторонних компонент под d2005, d2006.
- Установка ODBC - Watcom SQL.
- Установить размеры бумаги.
- Утечка памяти при поиске файлов.
- Турбо Дельфи.
- OpenGL для начинающих.
- Opening PowerPoint.
- Oracle иТStогеdРгос.
- Краткое описание Paradox.
- PID and SID процесса.
- PPP.
- Print Preview.
- Problem generating font matrix in Kylix.
- ProgressBar в колонке TListView.
- Могу ли я использовать в программе скрипт с Дельфи синтаксисом.
- Прокрутка ListView.
- Информация о дисках.
- Как получить серийный номер тома жесткого диска?
- Как сделать так, чтобы в компонент TEdit можно было вводить текст только на английской раскладке?