Dialer
Nomadic предлагает следующий код:
|
Function DialProvider(connection:string):boolean; // connection - имя учетной записи var pars:TRasDialParams; hRas:ThrasConn; r:integer; begin hRas:=0; strpcopy(pars.szEntryName,connection); // имя учетной записи pars.szPhoneNumber:=''; // номеp телефона - по умолчанию pars.szcallbacknumber:=''; // callback нам не нужен pars.szUserName:=''; // логин - по умолчанию pars.szPassWord:=''; // паpоль - по умолчанию pars.szDomain:=''; // аналогично с домейном pars.dwSize:=Sizeof(TRasDialParams); // вычисляем pазмеp записи r:=rasdial(nil,nil,pars,0,nil,hRas); // звоним if r<>0 then begin // если что-то неполучилось, то rasHangUp(hRas); // сбpасываем соединение result:=false; // ф-ция тепеpь веpнет false end else result:=true; // а если все ок - то true. end; |
P.S. Ras.pas бpать с www.torry.ru [001739]
Как можно определить, что компьютер подключен к Интернету?
Своим опытом делится Олег Кулабухов:
Положить компонент TCP на форму и
How can I tell at runtime if I am connected to the internet?
Answer:
You can use the TCP component to retrieve the Local IP address. If it is "0.0.0.0" then there is no connection.
Example:
|
procedure TForm1.Button1Click(Sender: TObject); begin if TCP1.LocalIp = '0.0.0.0' then ShowMessage('Your not connected!'); end; |
[001856]
Проверка URL
The_Sprite отвечает:
Данная функция позволяет Вам проверить существование определённого адреса(URL) в интернете. Естественно она может пригодиться веб-мастерам, у которых на сайте много ссылок, и необходимо с определённой периодичнойстью эти ссылки проверять.
URL может быть как с префиксом http:/ так и без него - эта функция добавляет префикс http:// если он отсутствует (необходимо для функции internetOpenUrl которая так же поддерживает FTP:// и gopher://
Эта функция проверяет только два возвращаемых кода '200'(ОК) или '302' (Редирект), но Вы можете заставить проверять функцию и другие коды. Для этого достаточно модифицировать строчку "result := ".
Платформа: Delphi 3.x (или выше)
|
uses wininet; Function CheckUrl(url:string):boolean; var hSession, hfile, hRequest: hInternet; dwindex,dwcodelen :dword; dwcode:array[1..20] of char; res : pchar; begin if pos('http://',lowercase(url))=0 then url := 'http://'+url; Result := false; hSession := InternetOpen('InetURL:/1.0', INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0); if assigned(hsession) then begin hfile := InternetOpenUrl( hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0); dwIndex := 0; dwCodeLen := 10; HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex); res := pchar(@dwcode); result:= (res ='200') or (res ='302'); if assigned(hfile) then InternetCloseHandle(hfile); InternetCloseHandle(hsession); end; end; |
[001377]
Работа с куками
Цель данного документа не в том, чтобы объяснить что такое куки и как их можно использовать. Вместо этого авторы документа предполагают, что вы знакомы с куками и с тем, как их можно использовать, и хотите узнать как нужно с ними работать из приложения, создаваемого для web-сервера на Delphi 3.
Объекты TWebRequest и TWebResponse, поставляемые с Delphi 3, имеют свойства, позволяющие легко воспользоваться куками. TWebRequest имеет свойства Cookie и CookieFields, позволящие приложению web-сервера читать заголовки куков, посылаемых как часть HTTP-запроса. Объект TWebResponse имеет свойство Cookies, позволяющее приложению web-сервера размещать куки на клиентской машине через заголовок куки как часть HTTP-запроса. Обычно это устанавливается с помощью метода SetCookieField.
Когда сервер отвечает на HTTP-запрос, в ответ он посылает документ с заголовком и "содержательной" секцией. Delphi обеспечивает возможность добавлять заголовок куки через свойство TWebResponse.Cookies. Но лучшим способом является использование метода SetCookieField. Приведенный ниже TWebActionItem демонстрирует технику использования метода SetCookieField для возвращения кука, требующегося браузеру. В данном примере в качестве домена используется localhost. Для работы в реальных условиях замените эту строку на строку с именем вашего домена. Третий параметр - косая черта. Это означает, что кука будет посылаться из браузера со всеми запросами, относящимся к данному домену. Полное описание данных параметров можно обнаружить в документе RFC 2109.
|
procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); var MyCookies: TStringList; begin MyCookies := TStringList.Create; with MyCookies do begin Add('Name=Frank Borland'); Add('Address=100 Borland Way'); Add('Product=Delphi'); end; with Response do begin SetCookieField(MyCookies, 'localhost', '/', (Now + 1), False); Content := 'Куки имплантировано'; end; end; |
При запросе, когда сервер HTTP запрашивает браузер клиента, имена всех куков пакуются в и включаются в заголовок в ответ на запрос HTTP. В Delphi 3 сделать это для приложения web-сервера можно двумя путями. Первый способ - как строку через свойство Cookie параметра TWebRequest у TWebActionItem. Также доступно как свойство TStrings с именем CookieFields. CookieFields - разобранное содержимое заголовка кука из сообщения HTTP-запроса.
В следующем TWebActionItems извлекается имя-значения и возвращается клиенту в виде пустой HTML-страницы. В первом примере кука возвращается в виде единственной строки, во втором - каждая пара имя-значение возвращается в отдельной строке.
|
procedure TWebModule1.WebModule1WebActionItem2Action(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); begin Response.Content := '' + Request.Cookie + ''; end; procedure TWebModule1.WebModule1WebActionItem3Action(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); var i: integer; begin Response.Content := ''; for i := 0 to (Request.CookieFields.Count - 1) do begin Response.Content := Response.Content + ' ' + Request.CookieFields[i] + ' '; end; Response.Content := Response.Content + ''; end; |
[001969]
TCLIENTSOCKET и TSERVERSOCKET: Почему сокету невозможно передать более чем 8K данных?
Поскольку IP-слой режет поток данных на куски размером 8k, разработчик должен явно включить целочисленную длину в начало потока, сообщающую приемную сторону размер ожидаемых данных, для нее очень важным является число 8k-пакетов, которые необходимо принять.
Поскольку Socket-компоненты являются простыми обертками для WinSock, а не протоколами с информационными заголовками (как было указано выше), разработчик должен сам беспокоиться об "заполнении" их данными. Для этого необходимо:
ПРИМЕЧАНИЕ: реализация может быть изменена разработчиком, поэтому приведены общие рекомендации.
заполнение данными источника пакетами с целочисленной длиной, целочисленная длина извлекается целевым хостом, подсчитываем количество принятых байт и сопоставляем с длиной пакета. если TotalBytesReceived <> LengthInteger, то следующий пакет является продолжением, в противном случае решаем, что далее в потоке следует ожидать очередной пакет.
ПРИМЕЧАНИЕ: это обрабатывается протоколами HTTP & FTP через информацию заголовка (например, 'Content\Length:').
[001967]
Панель Управления
Кто-нибудь знает как поместить приложение Delphi в Панель Управления?
Если вы используете Delphi3, добавьте модуль Cpl в файл проекта.
Вот код примера.
|
library Project1; {Измените "program" на "library"} uses Cpl, {используем модуль Cpl} Windows, Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} procedure ExecuteApp; begin Application.Initialize; Application.CreateForm(TForm1,Form1); Application.Run; end; {Сallback-функция для экспорта в Панель Управления} function CPlApplet(hwndCPl: THandle; uMsg: DWORD; lParam1, lParam2: LongInt):LongInt;stdcall; var NewCplInfo:PNewCplInfo; begin Result:=0; case uMsg of {Инициализация должна возвращать True.} CPL_INIT: Result:=1; {Число апплетов} CPL_GETCOUNT: Result:=1; {Помещаем информацию об этом апплете в Панель управления.} CPL_NEWINQUIRE: begin NewCplInfo:=PNewCplInfo(lParam2); with NewCplInfo^ do begin dwSize:=SizeOf(TNewCplInfo); dwFlags:=0; dwHelpContext:=0; lData:=0; {Иконка для отображения на Панели Управления.} hIcon:=LoadIcon(HInstance,'MAINICON'); {Имя апплета} szName:='Project1'; {Описание этого апплета.} szInfo:='Это тестовый апплет.'; szHelpFile:=''; end; end; {Выполнение апплета.} CPL_DBLCLK: ExecuteApp; else Result:=0; end; end; {Экспортирование функции CplApplet} exports CPlApplet; begin end. |
Для использования апплета измените его расширение с "dll" на "cpl" и поместите в системную директорию.
Апплет будет добавлен к списоку уже существующих (Display, Fonts, Mouse, System и другие). [000290]
Байтовый своппинг
Ознакомьтесь в файле помощь Delphi с функцией Swap. Но там в определении есть опечатка, правильно будет так:
| function Swap(X) : word; |
Ниже приведен пример использования:
|
var X: Word; begin X := Swap($1234); { $3412 } end; |
на первый взгляд ничего сложного.
Для своппинга 16-битного целого или слова, используйте следующий код:
| value: integer; value := swap(value); {внутренняя паскалевская функция} |
Для свапирования 32-битного длинного целого:
| value: longint; value := swap(value shr 16) or (longint(swap(value and $ffff)) shl 16); |
Я не знаю какие стандарты используются для значений с плавающей точкой, но если они соответствуют типам integer и longint (это моя догадка), то можно воспользоваться следующим кодом (для double):
|
value: double;
block: array[0..7] of byte absolute value;
temp: byte;
for i := 0 to 3 do begin temp := block[i]; block[i] := block[7-i]; block[7-i] := temp; end; |
При использовании типа real массив должен быть 0..5 и цикл от 0 до 2; при использовании типа comp, 0..7 и от 0 до 3; для single 0..3 и от 0 до 1; для extended 0..9 и от 0 дo 4.
Вы можете переделать это в процедуру, которая получает указатель на значение и его размер, например (возможно нуждается в оптимизации и улучшении):
| procedure swapper (valin: pointer; size: integer); var i: integer; temp: byte; val: ^byte; begin size := size - 1; val := valin; for i := 0 to (size div 2) do begin temp := val[i]; val[i] := val[size-i]; val[size-i] := temp; end; end; |
и затем так использовать это:
| swapper (@value, sizeof(value)); |
(Это должно работать для longint, integer и пр., но swap() более эффективен.)
Обратите внимание на то, что дополнительно к своппингу байтов, вы можете делать преобразование формата (например, из Microsoft floating point в ANSI); я не знаком глубоко с темой чисел с плавающей точкой, поэтому эту тему я опущу. Качественной проверкой может служить сдиг байтов и проверку получившегося значения на другой системе, признающей формат чисел, обрабатываемый Delphi.
...у меня была аналогичная проблема: я считывал с диска TColor в формате RGB ($RRGGBB), тогда как delphi пользуется форматом BGR.
Я решил свою проблему and'ингом начального числа с маской, извлекая этим необходимые значения и "устанавливая" их в мой формат. Вот так:
|
color := $F03200; r := (color and $FF0000) div $010000; {должно возвратить $F0} g := (color and $00FF00) div $000100; {должно возвратить $32} b := (color and $0000FF); {должно возвратить $00} newcolor := (b * $010000) + (g * $000100) + b; |
Если это сработает, то newcolor должен содержать $0032F0.
Вы можете использовать процедуру, написанную на языке ассемблер. Например, такую:
|
var result : byte; asm { mov cx,8 mov ah,0 mov al,<БАЙТ В ФОРМАТ BIG ENDIAN FORMAT> @do_loop shr al,1 shl ah,1 jcc @dont_set_bit ; просто осуществляем переход (правда, я не уверен что это правильно) xor ah,1 @dont_set_bit: loop do_loop mov result,al } |
Это скорее псевдо-код (поскольку мой ассемблер сильно хромает). Если вы хотите, чтобы код был более "портативным", то воспользуйтесь вместо inline-ассемблера паскалем (где можно использовать SHL - смещения бит налево и SHR - направо). [001970]
Число строкой I
Данный код "считает" до миллиона долларов. Поэкспериментируйте с ним - попробуйте "посчитать" до миллиарда, конвертировать ее в рубли или переделать ее для работы с русским языком. Только не забудьте прислать мне ваши решения!
|
unit uNum2Str; // Possible enhancements // Move strings out to resource files // Put in a general num2str utility interface function Num2Dollars( dNum: double ) : String; implementation uses SysUtils; function LessThan99( dNum: double ) : String; forward; // floating point modulus function FloatMod( i,j: double ): double; begin result := i - (Int(i/j) * j); end; function Hundreds( dNum: double ) : String; var workVar: double; begin if ( dNum < 100 ) or ( dNum > 999 ) then raise Exception.Create( 'hundreds range exceeded' ); result := ''; workVar := Int( dNum / 100 ); if workVar > 0 then result := LessThan99(workVar) + ' Hundred'; end; function OneToNine( dNum: Double ) : String; begin if ( dNum < 1 ) or (dNum > 9 ) then raise exception.create( 'onetonine: value out of range' ); result := 'woops'; if dNum = 1 then result := 'One' else if dNum = 2 then result := 'Two' else if dNum = 3 then result := 'Three' else if dNum = 4 then result := 'Four' else if dNum = 5.0 then result := 'Five' else if dNum = 6 then result := 'Six' else if dNum = 7 then result := 'Seven' else if dNum = 8 then result := 'Eight' else if dNum = 9 then result := 'Nine'; end; function ZeroTo19( dNum: double ) : String; begin if (dNum < 0) or (dNum > 19) then raise Exception.Create( 'Bad value in dNum' ); result := ''; if dNum = 0 then result := 'Zero' else if (dNum <= 1) and (dNum >= 9) then result := OneToNine( dNum ) else if dNum = 10 then result := 'Ten' else if dNum = 11 then result := 'Eleven' else if dNum = 12 then result := 'Twelve' else if dNum = 13 then result := 'Thirteen' else if dNum = 14 then result := 'Fourteen' else if dNum = 15 then result := 'Fifteen' else if dNum = 16 then result := 'Sixteen' else if dNum = 17 then result := 'Seventeen' else if dNum = 18 then result := 'Eighteen' else if dNum = 19 then result := 'Nineteen' else result := 'woops!'; end; function TwentyTo99( dNum: double ) : String; var BigNum: String; begin if ( dNum < 20 ) or ( dNum > 99 ) then raise exception.Create( 'TwentyTo99: dNum out of range!' ); BigNum := 'woops'; if dNum >= 90 then BigNum := 'Ninety' else if dNum >= 80 then BigNum := 'Eighty' else if dNum >= 70 then BigNum := 'Seventy' else if dNum >= 60 then BigNum := 'Sixty' else if dNum >= 50 then BigNum := 'Fifty' else if dNum >= 40 then BigNum := 'Forty' else if dNum >= 30 then BigNum := 'Thirty' else if dNum >= 20 then BigNum := 'Twenty'; // lose the big num dNum := FloatMod( dNum, 10 ); if dNum > 0.00 then result := BigNum + ' ' + OneToNine( dNum ) else result := BigNum; end; function LessThan99( dNum: double ) : String; begin if dNum <= 19 then result := ZeroTo19(dNum) else result := TwentyTo99(dNum); end; function Num2Dollars( dNum: double ) : String; var centsString: String; cents: double; workVar: double; begin result := ''; if dNum < 0 then raise Exception.Create( 'Negative numbers not supported' ); if dNum > 999999999.99 then raise Exception.Create( 'Num2Dollars only supports up to the millions at this point!' ); cents := (dNum - Int( dNum )) * 100.0; if cents = 0.0 then centsString := 'and 00/100 Dollars' else if cents < 10 then centsString := Format( 'and 0%1.0f/100 Dollars', [cents] ) else centsString := Format( 'and %2.0f/100 Dollars', [cents] ); dNum := Int( dNum - (cents / 100.0) ); // lose the cents // deal with million's if (dNum >= 1000000 ) and ( dNum <= 999999999 ) then begin workVar := dNum / 1000000; workVar := Int( workVar ); if (workVar <= 9) then result := ZeroTo19(workVar) else if ( workVar <= 99 ) then result := LessThan99( workVar ) else if ( workVar <= 999 ) then result := Hundreds( workVar ) else result := 'mill fubar'; result := result + ' Million'; dNum := dNum - ( workVar * 1000000 ); end; // deal with 1000's if (dNum >= 1000 ) and ( dNum <= 999999.99 ) then begin // doing the two below statements in one line of code yields some really // freaky floating point errors workVar := dNum/1000; workVar := Int( workVar ); if (workVar <= 9) then result := ZeroTo19(workVar) else if ( workVar <= 99 ) then result := LessThan99( workVar ) else if ( workVar <= 999 ) then result := Hundreds( workVar ) else result := 'thou fubar'; result := result + ' Thousand'; dNum := dNum - ( workVar * 1000 ); end; // deal with 100's if (dNum >= 100.00 ) and (dNum <= 999.99) then begin result := result + ' ' + Hundreds( dNum ); dNum := FloatMod( dNum, 100 ); end; // format in anything less than 100 if ( dNum > 0) or ((dNum = 0) and (Length( result ) = 0)) then begin result := result + ' ' + LessThan99( dNum ); end; result := result + ' ' + centsString; end; end. |
[000158]
Число строкой II
Нашлись умельцы работать с русским языком! Ниже я приведу письмо, пришедшее мне вскоре после опубликования предыдущего совета.
Валентин!
Только сегодня скачал и с удовольствием читаю Ваши "Советы". Дойдя до просьбы прислать русский вариант "Сумма прописью", выдрал эту процедуру из своей (старой, на Паскале, но до сих пор эксплуатирующейся) программы.
Александр
|
{------------------------ Деньги прописью ---------------------} function TextSum(S: double): string; function Conv999(M: longint; fm: integer): string; const c1to9m: array [1..9] of string [6] = ('один','два','три','четыре','пять','шесть','семь','восемь','девять'); c1to9f: array [1..9] of string [6] = ('одна','две','три','четыре','пять','шесть','семь','восемь','девять'); c11to19: array [1..9] of string [12] = ('одиннадцать','двенадцать','тринадцать','четырнадцать','пятнадцать', 'шестнадцать','семнадцать','восемнадцать','девятнадцать'); c10to90: array [1..9] of string [11] = ('десять','двадцать','тридцать','сорок','пятьдесят','шестьдесят', 'семьдесят','восемьдесят','девяносто'); c100to900: array [1..9] of string [9] = ('сто','двести','триста','четыреста','пятьсот','шестьсот','семьсот', 'восемьсот','девятьсот'); var s: string; i: longint; begin s := ''; i := M div 100; if i<>0 then s:=c100to900[i]+' '; M := M mod 100; i := M div 10; if (M>10) and (M<20) then s:=s+c11to19[M-10]+' ' else begin if i<>0 then s:=s+c10to90[i]+' '; M := M mod 10; if M<>0 then if fm=0 then s:=s+c1to9f[M]+' ' else s:=s+c1to9m[M]+' '; end; Conv999 := s; end; {--------------------------------------------------------------} var i: longint; j: longint; r: real; t: string; begin t := ''; j := Trunc(S/1000000000.0); r := j; r := S - r*1000000000.0; i := Trunc(r); if j<>0 then begin t:=t+Conv999(j,1)+'миллиард'; j := j mod 100; if (j>10) and (j<20) then t:=t+'ов ' else case j mod 10 of 0: t:=t+'ов '; 1: t:=t+' '; 2..4: t:=t+'а '; 5..9: t:=t+'ов '; end; end; j := i div 1000000; if j<>0 then begin t:=t+Conv999(j,1)+'миллион'; j := j mod 100; if (j>10) and (j<20) then t:=t+'ов ' else case j mod 10 of 0: t:=t+'ов '; 1: t:=t+' '; 2..4: t:=t+'а '; 5..9: t:=t+'ов '; end; end; i := i mod 1000000; j := i div 1000; if j<>0 then begin t:=t+Conv999(j,0)+'тысяч'; j := j mod 100; if (j>10) and (j<20) then t:=t+' ' else case j mod 10 of 0: t:=t+' '; 1: t:=t+'а '; 2..4: t:=t+'и '; 5..9: t:=t+' '; end; end; i := i mod 1000; j := i; if j<>0 then t:=t+Conv999(j,1); t := t+'руб. '; i := Round(Frac(S)*100.0); t := t+Long2Str(i)+' коп.'; TextSum := t; end; |
[000230]
Число строкой III
Вот еще одно решение, присланное читателем.
|
unit RoubleUnit; {$D Пропись © Близнец Антон '99 http:\\anton-bl.chat.ru\delphi\1001.htm } { 1000011.01->'Один миллион одинадцать рублей 01 копейка' } interface Function RealToRouble(c:Extended):String; implementation uses SysUtils,math; const Max000 = 6;{Кол-во триплетов - 000} MaxPosition=Max000*3;{Кол-во знаков в числе } //Аналог IIF в Dbase есть в proc.pas для основных типов, частично объявлена тут для независимости function IIF(i:Boolean;s1,s2:Char ):Char ;overload;begin if i then result:=s1 else result:=s2 end; function IIF(i:Boolean;s1,s2:String ):String ;overload;begin if i then result:=s1 else result:=s2 end; Function NumToStr(s:String):String;{Возвращает число прописью} Const c1000 :array[0..Max000]of string =('' ,'тысяч','миллион','миллиард','триллион','квадраллион','квинтиллион'); c1000w:array[0..Max000]of Boolean=(False,True ,False ,False ,False ,False ,False ); w:Array[False..True,'0'..'9']of String[3]=(('ов ',' ','а ','а ','а ','ов ','ов ','ов ','ов ','ов '), (' ' ,'а ','и ','и ','и ',' ',' ',' ',' ',' ')); function Num000toStr(S:String;woman:Boolean):String;{Num000toStr возвращает число для триплета} const c100:Array['0'..'9']of String=('','сто ' ,'двести ' ,'триста ' ,'четыреста ','пятьсот ','шестьсот ','семьсот ' ,'восемьсот ' ,'девятьсот '); c10:Array['0'..'9']of String=('','десять ','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '); c11:Array['0'..'9']of String=('','один','две','три','четыр','пят','шест','сем','восем','девят'); c1:Array[False..True,'0'..'9']of String=(('','один ','два ','три ','четыре ','пять ','шесть ','семь ','восемь ','девять '), ('','одна ','две ','три ','четыре ','пять ','шесть ','семь ','восемь ','девять ')); begin{Num000toStr} Result:=c100[s[1]]+iif((s[2]='1')and(s[3]>'0'),c11[s[3]]+'надцать ',c10[s[2]]+c1[woman,s[3]]); end;{Num000toStr} var s000:String[3]; isw,isMinus:Boolean; i:integer;//Счётчик триплетов Begin Result:='';i:=0; isMinus:=(s<>'') and (s[1]='-'); if isMinus then s:=Copy(s,2,Length(s)-1); while not((i>=Ceil(Length(s)/3))or(i>=Max000)) do begin s000:=Copy('00'+s,Length(s)-i*3,3); isw:=c1000w[i]; if (i>0)and(s000<>'000') then//тысячи и т.д. Result:=c1000[i]+w[Isw,iif(s000[2]='1','0',s000[3])]+Result; Result:=Num000toStr(s000,isw)+Result; Inc(i) end; if Result='' then Result:='ноль'; if isMinus then Result:='минус '+Result; End;{NumToStr} Function RealToRouble(c:Extended):String; Const ruble :array['0'..'9']of string[2]=('ей','ь','я','я','я','ей','ей','ей','ей','ей'); Kopeek:array['0'..'9']of string[3]=('ек','йка','йки','йки','йки','ек','ек','ек','ек','ек'); Function ending(const s:String):Char; var l:Integer;//С l на 8 байт коротче $50->$48->$3F begin//Возвращает индекс окончания l:=Length(s); Result:=iif((l>1) and (s[l-1]='1'),'0',s[l]); end; var rub:String[MaxPosition+3]; kop:String[2]; begin{Возвращает число прописью с рублями и копейками} Str(c:MaxPosition+3:2,Result); if Pos('E',Result)=0 then//Если число можно представить в строке <>1E+99 begin rub:=TrimLeft(Copy(Result,1,Length(Result)-3)); kop:= Copy(Result,Length(Result)-1,2) ; Result:=NumToStr(rub)+' рубл'+ ruble[ending(rub)] +' '+ kop +' копе'+Kopeek[ending(kop)]; Result:=AnsiUpperCase(Result[1])+Copy(Result,2,Length(Result)-1); end; end; end. |
[000237]
Число строкой IV
Вот еще одно решение, присланное читателем.
Уважаемый Валентин!
Вполне возможно, что код решения данной ф-ции несколько сыроват и неряшлив, но он работает для бухгалтерских программ (соблюдены правила написания суммы прописью). При вызове ф-ции надо также указывать сокращенные названия основных и разменных денежных единиц (например руб. коп.).
Редянов Денис
|
function CifrToStr(Cifr:String;Pr:Integer;Padeg:Integer) : string; {Функция возвращает прописью 1 цифры признак 3-единицы 2-десятки 1-сотни 4-11-19 Padeg - 1-нормально 2- одна, две } var i:Integer; begin i:=StrToInt(Cifr); if Pr = 1 Then case i of 1: CifrToStr :='сто'; 2: CifrToStr :='двести'; 3: CifrToStr :='триста'; 4: CifrToStr :='четыреста'; 5: CifrToStr :='пятьсот'; 6: CifrToStr :='шестьсот'; 7: CifrToStr :='семьсот'; 8: CifrToStr :='восемьсот'; 9: CifrToStr :='девятьсот'; 0: CifrToStr :=''; end else if Pr = 2 Then case i of 1: CifrToStr :=''; 2: CifrToStr :='двадцать'; 3: CifrToStr :='тридцать'; 4: CifrToStr :='сорок'; 5: CifrToStr :='пятьдесят'; 6: CifrToStr :='шестьдесят'; 7: CifrToStr :='семьдесят'; 8: CifrToStr :='восемьдесят'; 9: CifrToStr :='девяносто'; 0: CifrToStr :=''; end else if Pr = 3 Then case i of 1: if Padeg =1 Then CifrToStr :='один' else CifrToStr :='одна'; 2: if Padeg =1 Then CifrToStr :='два' else CifrToStr :='две'; 3: CifrToStr :='три'; 4: CifrToStr :='четыре'; 5: CifrToStr :='пять'; 6: CifrToStr :='шесть'; 7: CifrToStr :='семь'; 8: CifrToStr :='восемь'; 9: CifrToStr :='девять'; 0: CifrToStr :=''; end else if Pr = 4 Then case i of 1: CifrToStr :='одиннадцать'; 2: CifrToStr :='двенадцать'; 3: CifrToStr :='тринадцать'; 4: CifrToStr :='четырнадцать'; 5: CifrToStr :='пятнадцать'; 6: CifrToStr :='шестнадцать'; 7: CifrToStr :='семнадцать'; 8: CifrToStr :='восемнадцать'; 9: CifrToStr :='девятнадцать'; 0: CifrToStr :='десять'; end; end; function Rasryad(K:Integer;V:String) : string; {Функция возвращает наименование разряда в зависимости от последних 2 цифр его} Var j:Integer; Begin j := StrToInt(Copy(v,Length(v),1)); if (StrToInt(Copy(v,Length(v)-1,2))> 9) And (StrToInt(Copy(v,Length(v)-1,2))< 20) Then case K of 0: Rasryad :=''; 1: Rasryad :='тысяч'; 2: Rasryad :='миллионов'; 3: Rasryad :='миллиардов'; 4: Rasryad :='триллионов'; end else case K of 0: Rasryad :=''; 1: case j of 1: Rasryad :='тысяча'; 2..4: Rasryad :='тысячи'; else Rasryad :='тысяч'; end; 2: case j of 1: Rasryad :='миллион'; 2..4: Rasryad :='миллионa'; else Rasryad :='миллионов'; end; 3: case j of 1: Rasryad :='миллиард'; 2..4: Rasryad :='миллиарда'; else Rasryad :='миллиардов'; end; 4: case j of 1: Rasryad :='триллион'; 2..4: Rasryad :='триллиона'; else Rasryad :='триллионов'; end; end; end; function GroupToStr(Group:String;Padeg:Integer) : string; {Функция возвращает прописью 3 цифры} var i:Integer; S:String; begin S:=''; if (StrToInt(Copy(Group,Length(Group)-1,2))> 9) And (StrToInt(Copy(Group,Length(Group)-1,2))< 20) Then begin if Length(Group) = 3 Then S := S+' '+CifrToStr(Copy(Group,1,1),1,Padeg); S := S+' '+CifrToStr(Copy(Group,Length(Group),1),4,Padeg); end else for i:=1 to Length(Group) do S := S+' '+CifrToStr(Copy(Group,i,1),i-Length(Group)+3,Padeg); GroupToStr:=S; end; {Функция возвращает сумму прописью} function RubToStr(Rubs:Currency;Rub,Kop:String) : string; var i,j:Integer; R,K,S:String; begin S := CurrToStr(Rubs); S := Trim(S); if Pos(',',S) = 0 Then begin R:= S; K:= '00'; end else begin R:= Copy(S,0,(Pos(',',S)-1)); K:= Copy(S,(Pos(',',S)+1),Length(S)); end; S :=''; i:= 0; j := 1; While Length(R) >3 Do Begin if i = 1 Then j :=2 else j:=1; S := GroupToStr(Copy(R,Length(R)-2,3),j) +' '+Rasryad(i,Copy(R,Length(R)-2,3))+ ' ' +S; R := Copy(R,1,Length(R)-3); i:=i+1; end; if i = 1 Then j :=2 else j:=1; S := Trim( GroupToStr(R,j)+' '+Rasryad(i,R) + ' ' +S +' '+Rub+' '+K+' '+Kop); S := ANSIUpperCase(Copy(S,1,1)) + Copy(S,2,Length(S)-1); RubToStr := S; end; |
[000240]
Число строкой IX
Пришло от читателя письмо:
Посмотрел я что в разделе "Алгоритмы->Преобразование" много советов Число строкой, но нет преобразования на Украинский язык я подумал может модуль который я когда-то со славарем писал кому то спасет жизнь - так как у меня он уже года два работает.
|
unit UkrRecog; {копирайт непомню чей. Был для русских циферок, а я переделал под украинские} {если кто что найдет пришлите } {by Andrew Tkachenko, proektwo@netcity.ru, Ukraine, } interface Const UkrMonthString : array[1..12] of string[9] = ( 'січня', 'лютого', 'березня', 'квiтня', 'травня', 'червня', 'липня', 'серпня', 'вересня', 'жовтня', 'листопада','грудня'); Function UkrRecognizeAmount(Amount:real; CurrName,CurrSubname:string):string; implementation Uses Sysutils; Function UkrRecognizeAmount(Amount:real; CurrName,CurrSubname:string):string; {* CurrName in [грн.] CurrSubName in [коп.] Распознается число <= 999 999 999 999.99*} const suffBL:string=' '; suffDCT:string='дцять'; suffNA:string='надцять '; suffDCM:string='десят'; suffMZ:string='ь'; sot:string='сот'; st:string='ст'; aa:string='а'; ee:string='и'; {e} ii:string='і'; {и} oo:string='о'; ov:string='ів';{ов} C2:string='дв'; C3:string='тpи'; C4:string='чотир'; C5:string='п''ят'; C6:string='шіст'; C7:string='сім'; C8:string='вісім'; C9:string='дев''ят'; var i:byte; sAmount,sdInt,sdDec:string; IsMln,IsTha{,IsDcm},IsRange1019:boolean; currNum,endMlx,sResult:string; begin if (amount<=0)or(amount>999999999999.99) then begin Result:='<<<< Ошибка в диапазоне >>>>'; Exit; end; STR(Amount:16:2,sAmount); sdInt:=Copy(sAmount,1,13); sdDec:=Copy(sAmount,15,2); IsMln:=false; //IsDcm:=false; IsTha:=false; IsRange1019:=false; sResult:=''; for i:=1 to 13 do begin currNum:=Copy(sdInt,i,1); if currNum<>suffBL then begin case i of 5,6, 7:if currNum<>'0' then IsMln:=true; 8,9,10:if currNum<>'0' then IsTha:=true; end; if i IN [2,5,8,11] then {сотни} begin if currNum='1' then sResult:=sResult+st+oo+suffBL; if currNum='2' then sResult:=sResult+C2+ii+st+ii+suffBL; if currNum='3' then sResult:=sResult+C3+st+aa+suffBL; if currNum='4' then sResult:=sResult+C4+ee+st+aa+suffBL; if currNum='5' then sResult:=sResult+C5+sot+suffBL; if currNum='6' then sResult:=sResult+C6+sot+suffBL; if currNum='7' then sResult:=sResult+C7+sot+suffBL; if currNum='8' then sResult:=sResult+C8+sot+suffBL; if currNum='9' then sResult:=sResult+C9+sot+suffBL; end; if i IN [3,6,9,12] then{десятки} begin if currNum='1' then IsRange1019:=true; if currNum='2' then sResult:=sResult+C2+aa+suffDCT+suffBL; if currNum='3' then sResult:=sResult+C3+suffDCT+suffBL; if currNum='4' then sResult:=sResult+'соpок '; if currNum='5' then sResult:=sResult+C5+suffMZ+suffDCM+suffBL; if currNum='6' then sResult:=sResult+C6+suffMZ+suffDCM+suffBL; if currNum='7' then sResult:=sResult+C7+suffMZ+suffDCM+suffBL; if currNum='8' then sResult:=sResult+C8+suffMZ+suffDCM+suffBL; if currNum='9' then sResult:=sResult+'дев''ян'+oo+st+oo+suffBL; end; if i in [4,7,10,13] then {единицы} begin if (currNum='0') then if IsRange1019 then sResult:=sResult+suffDCM+suffMZ+suffBL; if (currNum='1') then begin if (i=13)and(not IsRange1019) then sResult:=sResult+'одна ' else begin if (i=10)and(IsRange1019) then sResult:=sResult+'оди' else if (i=10)and(not IsRange1019) then sResult:=sResult+'одна ' else sResult:=sResult+'один'{ин}; if IsRange1019 and (i=13) then sResult:=sResult+'адцять'+suffBL else if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+suffBL; end; end; if (currNum='2') then begin sResult:=sResult+C2; if (i=10)and(IsRange1019=False) then sResult:=sResult+ii else if (i=10)or(IsRange1019) then sResult:=sResult+aa else sResult:=sResult+{aa}ii; if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+suffBL; end; if (currNum='3') then begin sResult:=sResult+C3; if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+suffBL; end; if (currNum='4') then begin sResult:=sResult+C4; if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+ee+suffBL; end; if (currNum='5') then begin sResult:=sResult+C5; if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+suffMZ+suffBL; end; if (currNum='6') then begin sResult:=sResult+C6; if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+suffMZ+suffBL; end; if (currNum='7') then begin sResult:=sResult+C7; if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+suffBL; end; if (currNum='8') then begin sResult:=sResult+C8; if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+suffBL; end; if (currNum='9') then begin sResult:=sResult+C9; if IsRange1019 then sResult:=sResult+suffNA else sResult:=sResult+suffMZ+suffBL; end; end; endMlx:=''; case i of 4:begin if IsRange1019 then endMlx:=ov+suffBL else if currNum='1' then endMlx:=suffBL else if (currNum='2')or(currNum='3')or(currNum='4') then endMlx:=aa+suffBL else endMlx:=ov+suffBL; sResult:=sResult+'мiльярд'+endMlx; end; 7:if IsMln then begin if IsRange1019 then endMlx:=ov+suffBL else if currNum='1' then endMlx:=suffBL else if (currNum='2')or(currNum='3')or(currNum='4') then endMlx:=aa+suffBL else endMlx:=ov+suffBL; sResult:=sResult+'мiльйон'+endMlx; end; 10:if IsTha then begin if IsRange1019 then endMlx:=suffBL else if currNum='1' then endMlx:=aa+suffBL else if (currNum='2')or(currNum='3')or(currNum='4') then endMlx:=ii+suffBL else endMlx:=suffBL; sResult:=sResult+'тисяч'+endMlx; end; end;{case} if i IN [4,7,10,13] then IsRange1019:=false; end;{IF} end;{FOR} sResult:=sResult+CurrName+','+suffBL+sdDec+suffBL+CurrSubname ; sResult:=AnsiUpperCase(sResult[1])+Copy(sResult,2,length(sResult)-1); Result:=sResult; end; end. |
С уважением,
Andrew Tkachenko
ООО "Проект ВО"
Украина, г.Харьков.
[000857]
Число строкой V
Вот еще одно решение, присланное Олегом Клюкач.
|
unit Numinwrd; interface function sMoneyInWords( Nin: currency ): string; export; function szMoneyInWords( Nin: currency ): PChar; export; { Денежная сумма Nin в рублях и копейках прописью 1997, в.2.1, by О.В.Болдырев} implementation uses SysUtils,Dialogs,Math; type tri=string[4]; mood=1..2; gender=(m,f); uns =array[0..9] of string[7]; tns =array[0..9] of string[13]; decs=array[0..9] of string[12]; huns=array[0..9] of string[10]; nums=array[0..4] of string[8]; money=array[1..2] of string[5]; endings=array[gender,mood,1..3] of tri;{окончания числительных и денег} const units:uns =('','один ','два ','три ','четыре ','пять ', 'шесть ','семь ','восемь ','девять '); unitsf:uns=('','одна ','две ','три ','четыре ','пять ', 'шесть ','семь ','восемь ','девять '); teens:tns= ('десять ','одиннадцать ','двенадцать ','тринадцать ', 'четырнадцать ','пятнадцать ','шестнадцать ', 'семнадцать ','восемнадцать ','девятнадцать '); decades:decs=('','десять ','двадцать ','тридцать ','сорок ', 'пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ', 'девяносто '); hundreds:huns=('','сто ','двести ','триста ','четыреста ', 'пятьсот ','шестьсот ','семьсот ','восемьсот ', 'девятьсот '); numericals:nums=('','тысяч','миллион','миллиард','триллион'); RusMon:money=('рубл','копе'); ends:endings=((('','а','ов'),('ь','я','ей')), (('а','и',''),('йка','йки','ек'))); threadvar str: string; function EndingIndex(Arg: integer): integer; begin if ((Arg div 10) mod 10) <> 1 then case (Arg mod 10) of 1: Result := 1; 2..4: Result := 2; else Result := 3; end else Result := 3; end; function sMoneyInWords( Nin: currency ): string; { Число Nin прописью, как функция } var // str: string; g: gender; //род Nr: comp; {целая часть числа} Fr: integer; {дробная часть числа} i,iTri,Order: longint; {триада} procedure Triad; var iTri2: integer; un, de, ce :byte; //единицы, десятки, сотни function GetDigit: byte; begin Result := iTri2 mod 10; iTri2 := iTri2 div 10; end; begin iTri := trunc(Nr/IntPower(1000,i)); Nr := Nr - int( iTri*IntPower(1000,i)); iTri2:=iTri; if iTri > 0 then begin un := GetDigit; de := GetDigit; ce := GetDigit; if i=1 then g:=f else g:=m; {женского рода только тысяча} str := TrimRight(str)+' '+Hundreds[ce]; if de = 1 then str := TrimRight(str)+' '+Teens[un] else begin str := TrimRight(str)+' '+Decades[de]; case g of m: str := TrimRight(str)+' '+Units[un]; f: str := TrimRight(str)+' '+UnitsF[un]; end; end; if length(numericals[i]) > 1 then begin str := TrimRight(str)+' '+numericals[i]; str := TrimRight(str)+ends[g,1,EndingIndex(iTri)]; end; end; //triad is 0 ? if i=0 then Exit; Dec(i); Triad; end; begin str := ''; Nr := int( Nin ); Fr := round( Nin*100 + 0.00000001 ) mod 100; if Nr>0 then Order := trunc(Log10(Nr)/3) else begin str := 'ноль'; Order := 0 end; if Order > High(numericals) then raise Exception.Create('Слишком большое число для суммы прописью'); i:= Order; Triad; str := Format('%s %s%s %.2d %s%s', [Trim(str),RusMon[1],ends[m,2,EndingIndex(iTri)], Fr, RusMon[2],ends[f,2,EndingIndex(Fr)]]); str[1] := (ANSIUpperCase(copy(str,1,1)))[1]; str[Length(str)+1] := #0; Result := str; end; function szMoneyInWords( Nin: currency ): PChar; begin sMoneyInWords(Nin); Result := @(str[1]); end; end. |
[000243]
Число строкой VI
Еще два решения конвертации денежной суммы на английском языке
|
Function HundredAtATime(TheAmount:Integer):String; var TheResult : String; Begin TheResult := ''; TheAmount := Abs(TheAmount); While TheAmount > 0 do Begin If TheAmount >= 900 Then Begin TheResult := TheResult + 'Nine hundred '; TheAmount := TheAmount - 900; End; If TheAmount >= 800 Then Begin TheResult := TheResult + 'Eight hundred '; TheAmount := TheAmount - 800; End; If TheAmount >= 700 Then Begin TheResult := TheResult + 'Seven hundred '; TheAmount := TheAmount - 700; End; If TheAmount >= 600 Then Begin TheResult := TheResult + 'Six hundred '; TheAmount := TheAmount - 600; End; If TheAmount >= 500 Then Begin TheResult := TheResult + 'Five hundred '; TheAmount := TheAmount - 500; End; If TheAmount >= 400 Then Begin TheResult := TheResult + 'Four hundred '; TheAmount := TheAmount - 400; End; If TheAmount >= 300 Then Begin TheResult := TheResult + 'Three hundred '; TheAmount := TheAmount - 300; End; If TheAmount >= 200 Then Begin TheResult := TheResult + 'Two hundred '; TheAmount := TheAmount - 200; End; If TheAmount >= 100 Then Begin TheResult := TheResult + 'One hundred '; TheAmount := TheAmount - 100; End; If TheAmount >= 90 Then Begin TheResult := TheResult + 'Ninety '; TheAmount := TheAmount - 90; End; If TheAmount >= 80 Then Begin TheResult := TheResult + 'Eighty '; TheAmount := TheAmount - 80; End; If TheAmount >= 70 Then Begin TheResult := TheResult + 'Seventy '; TheAmount := TheAmount - 70; End; If TheAmount >= 60 Then Begin TheResult := TheResult + 'Sixty '; TheAmount := TheAmount - 60; End; If TheAmount >= 50 Then Begin TheResult := TheResult + 'Fifty '; TheAmount := TheAmount - 50; End; If TheAmount >= 40 Then Begin TheResult := TheResult + 'Fourty '; TheAmount := TheAmount - 40; End; If TheAmount >= 30 Then Begin TheResult := TheResult + 'Thirty '; TheAmount := TheAmount - 30; End; If TheAmount >= 20 Then Begin TheResult := TheResult + 'Twenty '; TheAmount := TheAmount - 20; End; If TheAmount >= 19 Then Begin TheResult := TheResult + 'Nineteen '; TheAmount := TheAmount - 19; End; If TheAmount >= 18 Then Begin TheResult := TheResult + 'Eighteen '; TheAmount := TheAmount - 18; End; If TheAmount >= 17 Then Begin TheResult := TheResult + 'Seventeen '; TheAmount := TheAmount - 17; End; If TheAmount >= 16 Then Begin TheResult := TheResult + 'Sixteen '; TheAmount := TheAmount - 16; End; If TheAmount >= 15 Then Begin TheResult := TheResult + 'Fifteen '; TheAmount := TheAmount - 15; End; If TheAmount >= 14 Then Begin TheResult := TheResult + 'Fourteen '; TheAmount := TheAmount - 14; End; If TheAmount >= 13 Then Begin TheResult := TheResult + 'Thirteen '; TheAmount := TheAmount - 13; End; If TheAmount >= 12 Then Begin TheResult := TheResult + 'Twelve '; TheAmount := TheAmount - 12; End; If TheAmount >= 11 Then Begin TheResult := TheResult + 'Eleven '; TheAmount := TheAmount - 11; End; If TheAmount >= 10 Then Begin TheResult := TheResult + 'Ten '; TheAmount := TheAmount - 10; End; If TheAmount >= 9 Then Begin TheResult := TheResult + 'Nine '; TheAmount := TheAmount - 9; End; If TheAmount >= 8 Then Begin TheResult := TheResult + 'Eight '; TheAmount := TheAmount - 8; End; If TheAmount >= 7 Then Begin TheResult := TheResult + 'Seven '; TheAmount := TheAmount - 7; End; If TheAmount >= 6 Then Begin TheResult := TheResult + 'Six '; TheAmount := TheAmount - 6; End; If TheAmount >= 5 Then Begin TheResult := TheResult + 'Five '; TheAmount := TheAmount - 5; End; If TheAmount >= 4 Then Begin TheResult := TheResult + 'Four '; TheAmount := TheAmount - 4; End; If TheAmount >= 3 Then Begin TheResult := TheResult + 'Three '; TheAmount := TheAmount - 3; End; If TheAmount >= 2 Then Begin TheResult := TheResult + 'Two '; TheAmount := TheAmount - 2; End; If TheAmount >= 1 Then Begin TheResult := TheResult + 'One '; TheAmount := TheAmount - 1; End; End; HundredAtATime := TheResult; End; Function Real2CheckAmount(TheAmount:Real):String; Var IntVal : LongInt; TmpVal : Integer; TmpStr, RetVal : String; begin TheAmount := Abs(TheAmount); { центы } TmpVal := Round(Frac(TheAmount) * 100); IntVal := Trunc(TheAmount); TmpStr := HundredAtATime(TmpVal); If TmpStr = '' Then TmpStr := 'Zero '; RetVal := TmpStr + 'cents'; If IntVal > 0 Then RetVal := 'dollars and ' + RetVal; { сотни } TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); RetVal := TmpStr + RetVal; { тысячи } TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); If TmpStr <> '' Then RetVal := TmpStr + 'Thousand ' + RetVal; { миллионы } TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); If TmpStr <> '' Then RetVal := TmpStr + 'Million ' + RetVal; { миллиарды } TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000); IntVal := Trunc((IntVal * 1.0) / 1000.0); TmpStr := HundredAtATime(TmpVal); If TmpStr <> '' Then RetVal := TmpStr + 'Billion ' + RetVal; Real2CheckAmount := RetVal; end; |
Хммммм... вроде бы работает, но как все громоздко и неуклюже.... добавьте в код немного рекурсии и вы получите более элегантную программу..:)))
|
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) num: TEdit; spell: TEdit; Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } function trans9(num: integer): string; function trans19(num: integer): string; function trans99(num: integer): string; function IntToSpell(num: integer): string; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} function TForm1.IntToSpell(num: integer): string; var spell: string; hspell: string; hundred: string; thousand: string; tthousand: string; hthousand: string; million: string; begin if num ≶ 10 then spell := trans9(num); {endif} if (num < 20) and (num > 10) then spell := trans19(num); {endif} if (((num < 100) and (num > 19)) or (num = 10)) then begin hspell := copy(IntToStr(num),1,1) + '0'; spell := trans99(StrToInt(hspell)); hspell := copy(IntToStr(num),2,1); spell := spell + ' ' + IntToSpell(StrToInt(hspell)); end; if (num < 1000) and (num > 100) then begin hspell := copy(IntToStr(num),1,1); hundred := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),2,2); hundred := hundred + ' hundred and ' + IntToSpell(StrToInt(hspell)); spell := hundred; end; if (num < 10000) and (num > 1000) then begin hspell := copy(IntToStr(num),1,1); thousand := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),2,3); thousand := thousand + ' thousand ' + IntToSpell(StrToInt(hspell)); spell := thousand; end; if (num < 100000) and (num > 10000) then begin hspell := copy(IntToStr(num),1,2); tthousand := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),3,3); tthousand := tthousand + ' thousand ' + IntToSpell(StrToInt(hspell)); spell := tthousand; end; if (num < 1000000) and (num > 100000) then begin hspell := copy(IntToStr(num),1,3); hthousand := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),4,3); hthousand := hthousand + ' thousand and ' + IntToSpell(StrToInt(hspell)); spell := hthousand; end; if (num < 10000000) and (num > 1000000) then begin hspell := copy(IntToStr(num),1,1); million := IntToSpell(StrToInt(hspell)); hspell := copy(IntToStr(num),2,6); million := million + ' million and ' + IntToSpell(StrToInt(hspell)); spell := million; end; IntToSpell := spell; end; function TForm1.trans99(num: integer): string; var spell: string; begin case num of 10 : spell := 'ten'; 20 : spell := 'twenty'; 30 : spell := 'thirty'; 40 : spell := 'fourty'; 50 : spell := 'fifty'; 60 : spell := 'sixty'; 70 : spell := 'seventy'; 80 : spell := 'eighty'; 90 : spell := 'ninty'; end; trans99 := spell; end; function TForm1.trans19(num: integer): string; var spell: string; begin case num of 11 : spell := 'eleven'; 12 : spell := 'twelve'; 13 : spell := 'thirteen'; 14 : spell := 'fourteen'; 15 : spell := 'fifteen'; 16 : spell := 'sixteen'; 17 : spell := 'seventeen'; 18 : spell := 'eighteen'; 19 : spell := 'nineteen'; end; trans19 := spell; end; function TForm1.trans9(num: integer): string; var spell : string; begin case num of 1 : spell := 'one'; 2 : spell := 'two'; 3 : spell := 'three'; 4 : spell := 'four'; 5 : spell := 'five'; 6 : spell := 'six'; 7 : spell := 'seven'; 8 : spell := 'eight'; 9 : spell := 'nine'; end; trans9 := spell; end; procedure TForm1.Button1Click(Sender: TObject); var numb: integer; begin spell.text := IntToSpell(StrToInt(num.text)); end; |
[000256]
Число строкой VII
Здравствуйте Валентин.
Честно, давно ждал подобного журнала в электронном виде. Решил послать своё творчество которое уже немало отработало, опять же, преобразование числа в пропись, отличающееся от опубликованных программок тем, что слова для прописи хранятся в отдельном файле (lang.cnf), по аналогии с подуктами 1C. Это позволяет изменять национальную валюту.
Если поэкспериментировать, с массивом Univer, в котором хранятся окончания, можно добиться преобразования для многих языков, не сказал ли я чего лишнего. :)
Надеюсь, моя версия Вам понравится.
С наилучшими пожеланиями,
Панченко Сергей
Казахстан, Алматы,
Sergey@arna.kz
BuchUtil.pas
|
unit BuchUtil; interface uses IniFiles, SysUtils; function DoubleChar(ch: string): string; function NumToSampl(N: string): string; function MoneyToSampl(M: Currency): string; procedure LexemsToDim(fstr: string; var dim: array of string); var NameNum: array[0..9, 1..4]of string;//массив имён чисел Ext: array[0..4, 1..3]of string; //массив расшиений (тысячи, миллионы ...) Univer: array[1..9, 1..4]of integer;//массив окончаний Rubl: array[1..3]of String; //массив имен рублей Cop: array[1..3]of String; //массив имен копеек Zero: string; //название нуля One: string; //единица "одна" Two: string; //двойка "две" fFile: TIniFile; //файл, откуда загружается пропись fString: string; fDim: array [0..9] of string; i: integer; implementation {заполняет массив Dim лексемами} procedure LexemsToDim(fstr: string; var dim: array of string); var i, j: integer; flex: string; begin if Length(fstr)>0 then begin i:=1; j:=0; while i-1<Length(fstr) do begin if fstr[i]=',' then begin dim[j]:=flex+' '; inc(j); flex:=''; end else flex:=flex+fstr[i]; inc(i); end; end; end; {преобразует число в пропись процедура использует файл lang.cnf} function NumToSampl(N: string): string; var k, i, i_indx: integer; number, string_num: string; index: integer; pos: integer; fl_ext: boolean; begin fl_ext:=true; i:=1; String_num:=''; number:=Trim(N); k:=length(number); if (k=1)and(number='0')then String_num:=Zero else begin pos:=0; while (k>0) do begin if (k<>1)and(i=1)and(length(number)<>1)and(copy(number,k-1,1)='1') and(copy(number,k,1)<>'0') then begin index:=StrToInt(copy(number,k,1)); dec(k); inc(i); i_indx:=4; end else begin index:=StrToInt(copy(number,k,1)); i_indx:=i; end; if (NameNum[index,i_indx]<>'')and(fl_ext=true)then begin String_num:=Ext[pos,Univer[index,i_indx]]+String_num; fl_ext:=false; end; if (index=1)and(pos=1)and(i=1)then String_num:=One+String_num else if (index=2)and(pos=1)and(i=1)then String_num:=Two+String_num else String_num:=NameNum[index,i_indx]+String_num; inc(i); if i=4 then begin i:=1; inc(pos); fl_ext:=true end; dec(k); end; end; if Trim(String_Num)<>'' then begin String_num[1]:=CHR(ORD(String_num[1])-32); Result:=String_num; end; end; {Преобразует х в 0х} function DoubleChar(ch: string): string; begin if Length(ch)=1 then Result:='0'+ch else Result:=ch; end; {преобразует денежную сумму в пропись} function MoneyToSampl(M: Currency): string; var Int_Part, idx, idxIP, idxRP: integer; Int_Str, Real_Part, Sampl: string; begin Int_Part:=Trunc(Int(M)); Int_Str:=IntToStr(Int_Part); Real_Part:=DoubleChar(IntToStr(Trunc(Int((M-Int_Part+0.001)*100)))); Sampl:=NumToSampl(Int_Str); idx:=StrToInt(Int_Str[Length(Int_Str)]); if idx=0 then idx:=5; idxIP:=Univer[idx, 1]; idx:=StrToInt(Real_Part[Length(Real_Part)]); if idx=0 then idx:=5; idxRP:=Univer[idx, 1]; Result:=Sampl+Rubl[idxIP]+Real_Part+' '+Cop[idxRP]; end; Initialization {Предположим файл находится на C:\ диске} fFile:=TIniFile.Create('c:\lang.cnf'); try {Заполнение массива рублей} fString:=fFile.ReadString('Money', 'Rub', ','); LexemsToDim(fString, Rubl); {Заполнение массива копеек} fString:=fFile.ReadString('Money', 'Cop', ','); LexemsToDim(fString, Cop); {Заполнение массива чисел} fString:=fFile.ReadString('Nums', 'Numbers', ','); LexemsToDim(fString, fdim); NameNum[0, 1]:=''; for i:=1 to 9 do NameNum[i, 1]:=fdim[i-1]; {Заполнение массива десятков} fString:=fFile.ReadString('Nums', 'Tens', ','); LexemsToDim(fString, fdim); NameNum[0, 2]:=''; for i:=1 to 9 do NameNum[i, 2]:=fdim[i-1]; {Заполнение массива сотен} fString:=fFile.ReadString('Nums', 'Hundreds', ','); LexemsToDim(fString, fdim); NameNum[0, 3]:=''; for i:=1 to 9 do NameNum[i, 3]:=fdim[i-1]; {Заполнение массива чисел после десяти} fString:=fFile.ReadString('Nums', 'AfterTen', ','); LexemsToDim(fString, fdim); NameNum[0, 4]:=''; for i:=1 to 9 do NameNum[i, 4]:=fdim[i-1]; {Заполнение расширений чисел} Ext[0,1]:=''; Ext[0,2]:=''; Ext[0,3]:=''; {Тысячи} fString:=fFile.ReadString('Nums', 'Thou', ','); LexemsToDim(fString, fdim); for i:=1 to 3 do Ext[1, i]:=fdim[i-1]; {Миллионы} fString:=fFile.ReadString('Nums', 'Mill', ','); LexemsToDim(fString, fdim); for i:=1 to 3 do Ext[2, i]:=fdim[i-1]; {Миллиарды} fString:=fFile.ReadString('Nums', 'Bill', ','); LexemsToDim(fString, fdim); for i:=1 to 3 do Ext[3, i]:=fdim[i-1]; {Триллион} fString:=fFile.ReadString('Nums', 'Thrill', ','); LexemsToDim(fString, fdim); for i:=1 to 3 do Ext[4, i]:=fdim[i-1]; Zero:=fFile.ReadString('Nums', 'Zero', '0'); if Zero[Length(Zero)]=',' then Zero:=Copy(Zero, 1, Length(Zero)-1)+' '; One:=fFile.ReadString('Nums', 'One', '1'); if One[Length(One)]=',' then One:=Copy(One, 1, Length(One)-1)+' '; Two:=fFile.ReadString('Nums', 'Two', '0'); if Two[Length(Two)]=',' then Two:=Copy(Two, 1, Length(Two)-1)+' '; {Заполнение таблицы окончаний} Univer[1,1]:=1; Univer[1,2]:=2; Univer[1,3]:=2; Univer[1,4]:=2; Univer[2,1]:=3; Univer[2,2]:=2; Univer[2,3]:=2; Univer[2,4]:=2; Univer[3,1]:=3; Univer[3,2]:=2; Univer[3,3]:=2; Univer[3,4]:=2; Univer[4,1]:=3; Univer[4,2]:=2; Univer[4,3]:=2; Univer[4,4]:=2; Univer[5,1]:=2; Univer[5,2]:=2; Univer[5,3]:=2; Univer[5,4]:=2; Univer[6,1]:=2; Univer[6,2]:=2; Univer[6,3]:=2; Univer[6,4]:=2; Univer[7,1]:=2; Univer[7,2]:=2; Univer[7,3]:=2; Univer[7,4]:=2; Univer[8,1]:=2; Univer[8,2]:=2; Univer[8,3]:=2; Univer[8,4]:=2; Univer[9,1]:=2; Univer[9,2]:=2; Univer[9,3]:=2; Univer[9,4]:=2; finally fFile.Free; end; end. |
Lang.cnf
|
[Nums] Numbers=один,два,три,четыре,пять,шесть,семь,восемь,девять, One=одна, Two=две, Tens=десять,двадцать,тридцать,сорок,пятьдесят,шестьдесят,семьдесят,восемьдесят,девяносто, Hundreds=сто,двести,триста,четыреста,пятьсот,шестьсот,семьсот,восемьсот,девятьсот, AfterTen=одиннадцать,двенадцать,тринадцать,четырнадцать,пятнадцать,шестнадцать,семнадцать,восемнадцать,девятнадцать, Zero=ноль, Thou=тысяча,тысяч,тысячи, Mill=миллион,миллионов,миллиона, Bill=миллиард,миллиардов,миллиарда, Thrill=триллион,триллионов,триллиона, [Money] Rub=рубль,рублей,рубля, Cop=копейка,копеек,копейки, |
[000562]
Число строкой VIII
|
function NumToStr(n: double; c: byte = 0): string; (* c=0 - 21.05 -> 'Двадцать один рубль 05 копеек.' с=1 - 21.05 -> 'двадцать один' c=2 - 21.05 -> '21-05', 21.00 -> '21=' *) const digit: array[0..9] of string = ('ноль', 'оди', 'два', 'три', 'четыр', 'пят', 'шест', 'сем', 'восем', 'девят'); var ts, mln, mlrd, SecDes: Boolean; len: byte; summa: string; function NumberString(number: string): string; var d, pos: byte; function DigitToStr: string; begin result := ''; if (d <> 0) and ((pos = 11) or (pos = 12)) then mlrd := true; if (d <> 0) and ((pos = 8) or (pos = 9)) then mln := true; if (d <> 0) and ((pos = 5) or (pos = 6)) then ts := true; if SecDes then begin case d of 0: result := 'десять '; 2: result := 'двенадцать ' else result:=digit[d]+'надцать ' end; case pos of 4: result := result + 'тысяч '; 7: result := result + 'миллионов '; 10: result := result + 'миллиардов ' end; SecDes := false; mln := false; mlrd := false; ts := false end else begin if (pos = 2) or (pos = 5) or (pos = 8) or (pos = 11) then case d of 1: SecDes := true; 2, 3: result := digit[d] + 'дцать '; 4: result := 'сорок '; 9: result := 'девяносто '; 5..8: result := digit[d] + 'ьдесят ' end; if (pos = 3) or (pos = 6) or (pos = 9) or (pos = 12) then case d of 1: result := 'сто '; 2: result := 'двести '; 3: result := 'триста '; 4: result := 'четыреста '; 5..9: result:=digit[d]+'ьсот ' end; if (pos = 1) or (pos = 4) or (pos = 7) or (pos = 10) then case d of 1: result := 'один '; 2,3: result := digit[d] + ' '; 4: result := 'четыре '; 5..9: result := digit[d] + 'ь ' end; if pos = 4 Then begin case d of 0: if ts then result := 'тысяч '; 1: result := 'одна тысяча '; 2: result := 'две тысячи '; 3,4: result := result + 'тысячи '; 5..9: result := result + 'тысяч ' end; ts := false end; if pos = 7 then begin case d of 0: if mln then result := 'миллионов '; 1: result := result + 'миллион '; 2, 3, 4: result := result + 'миллиона '; 5..9: result := result + 'миллионов ' end; mln := false end; if pos = 10 then begin case d of 0: if mlrd then result := 'миллиардов '; 1: result := result + 'миллиард '; 2, 3, 4: result := result + 'миллиарда '; 5..9: result := result + 'миллиардов ' end; mlrd := false end end end; begin result := ''; ts := false; mln := false; mlrd := false; SecDes := false; len := length(number); if (len = 0) or (number = '0') then result := digit[0] else for pos := len downto 1 do begin d := StrToInt(copy(number, len - pos + 1, 1)); result := result + DigitToStr end end; function MoneyString(number: string): string; var s: string[1]; n: string; begin len := length(number); n := copy(number, 1, len-3); result := NumberString(n); s := AnsiUpperCase(result[1]); delete(result, 1, 1); result := s + result; if len < 2 then begin if len = 0 then n := '0'; len := 2; n := '0' + n end; if copy(n, len - 1, 1) = '1' then result := result + 'рублей' else begin case StrToInt(copy(n, len, 1)) of 1: result := result + 'рубль'; 2, 3, 4: result := result + 'рубля' else result := result + 'рублей' end end; len := length(number); n := copy(number, len - 1, len); if copy(n, 1, 1) = '1' then n := n + ' копеек.' else begin case StrToInt(copy(n, 2, 1)) of 1: n := n + ' копейка.'; 2, 3, 4: n := n + ' копейки.' else n := n + ' копеек.' end end; result := result + ' ' + n end; // Основная часть begin case c of 0: result := MoneyString(FormatFloat('0.00', n)); 1: result := NumberString(FormatFloat('0', n)); 2: begin summa := FormatFloat('0.00', n); len := length(summa); if copy(summa, len - 1, 2) = '00' then begin delete(summa, len - 2, 3); result := summa + '=' end else begin delete(summa, len - 2, 1); insert('-', summa, len - 2); result := summa; end; end end; end; |
С уважением, Васильев Сергей Геннадьевич, Благовещенск, vs2000@mail.ru [000580]
Число строкой X
Сергей AKA WildSery прислал свой вариант:
Привожу мой вариант, написал для своего приложения за 20 минут. В силу специфики приложения не утруждал себя прописью полностью "рублей" и "копеек", а ограничился "руб." и "коп.", а также не было необходимости в знаке числа, по это все добавляется буквально 3-4 строками.
|
function currency2Str (value: double): string; const hundreds: array [0..9] of string = ('',' сто',' двести',' триста',' четыреста',' пятьсот',' шестьсот',' семьсот',' восемьсот',' девятьсот'); tens: array [0..9] of string = ('','',' двадцать',' тридцать',' сорок',' пятьдесят',' шестьдесят',' семьдесят',' восемьдесят',' девяносто'); ones: array [0..19] of string = ('','','',' три',' четыре',' пять',' шесть',' семь',' восемь',' девять',' десять',' одиннадцать',' двенадцать',' тринадцать',' четырнадцать',' пятнадцать',' шестнадцать',' семнадцать',' восемнадцать',' девятнадцать'); razryad: array [0..6] of string = ('',' тысяч',' миллион',' миллиард',' триллион',' квадриллион',' квинтиллион'); var s: string; i: integer; val: int64; function shortNum(s: string; raz: integer): string; begin Result:=hundreds[StrToInt(s[1])]; if StrToInt(s)=0 then Exit; if s[2]<>'1' then begin Result:=Result+tens[StrToInt(s[2])]; case StrToInt(s[3]) of 1: if raz=1 then Result:=Result+' одна' else Result:=Result+' один'; 2: if raz=1 then Result:=Result+' две' else Result:=Result+' два'; else Result:=Result+ones[StrToInt(s[3])]; end; Result:=Result+razryad[raz]; case StrToInt(s[3]) of 0,5,6,7,8,9: if raz>1 then Result:=Result+'ов'; 1: if raz=1 then Result:=Result+'а'; 2,3,4: if raz=1 then Result:=Result+'и' else if raz>1 then Result:=Result+'а'; end; end else begin Result:=Result+ones[StrToInt(Copy(s,2,2))]; Result:=Result+razryad[raz]; if raz>1 then Result:=Result+'ов'; end; end; begin val:=Trunc(value); if val=0 then begin Result:='ноль'; Exit; end; s:=IntToStr(val); Result:=''; i:=0; while Length(s)>0 do begin Result:=shortNum(Copy('00'+s,Length('00'+s)-2,3),i)+Result; if Length(s)>3 then s:=Copy(s,1,Length(s)-3) else s:=''; inc(i); end; s:=IntToStr(Trunc((value-val)*100+0.5)); Result:=Result+' руб. '+s+' коп.'; end; |
[001530]
HEX -> Integer Решение 1
|
var i : integer s : string; begin s := '$' + ThatHexString; i := StrToInt(a); end; |
|
CONST HEX : ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15); VAR str : String; Int, i : integer; BEGIN READLN(str); Int := 0; FOR i := 1 TO Length(str) DO IF str[i] < 'A' THEN Int := Int * 16 + ORD(str[i]) - 48 ELSE Int := Int * 16 + HEX[str[i]]; WRITELN(Int); READLN; END. |
Преобразование десятичного числа в шестнадцатиричное Самое простое преобразование - через строку.
| HexString := Format('%0x',DecValue); |
Преобразование ASCII в шестнадцатиричное представление Строка представляет собой массив байтов в виде ASCII-символов. Необходимо организовать преобразование типов по аналогии с Delphi-функциями Ord и Chr.
Функция BytesToHexStr преобразует, к примеру, набор байтов [0,1,1,0] в строку '30313130', HexStrToBytes выполнит обратное преобразование.
|
unit Hexstr; interface uses String16, SysUtils; Type PByte = ^BYTE; procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD); procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer); procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD); implementation procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD); Const HexChars : Array[0..15] of Char = '0123456789ABCDEF'; var i, j: WORD; begin SetLength(hHexStr, (InputLength * 2)); FillChar(hHexStr, sizeof(hHexStr), #0); j := 1; for i := 1 to InputLength do begin hHexStr[j] := Char(HexChars[pbyteArray^ shr 4]); inc(j); hHexStr[j] := Char(HexChars[pbyteArray^ and 15]); inc(j); inc(pbyteArray); end; end; procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD); var i: WORD; c: byte; begin SetLength(Response, InputLength); FillChar(Response, SizeOf(Response), #0); for i := 0 to (InputLength - 1) do begin c := BYTE(hexbytes[i]) And BYTE($f); if c > 9 then Inc(c, $37) else Inc(c, $30); Response[i + 1] := char(c); end;{for} end; procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer); {pbyteArray указывает на область памяти, хранящей результаты} var i, j: WORD; tempPtr: PChar; twoDigits : String[2]; begin tempPtr := pbyteArray; j := 1; for i := 1 to (Length(hHexStr) DIV 2) do begin twoDigits := Copy(hHexStr, j, 2); Inc(j, 2); PByte(tempPtr)^ := StrToInt('$' + twoDigits); Inc(tempPtr); end;{for} end; end. |
|
UNIT String16. interface {$IFNDEF Win32} procedure SetLength(var S: string; Len: Integer); procedure SetString(var Dst: string; Src: PChar; Len: Integer); {$ENDIF} implementation {$IFNDEF Win32} procedure SetLength(var S: string; Len: Integer); begin if Len > 255 then S[0] := Chr(255) else S[0] := Chr(Len) end; procedure SetString(var Dst: string; Src: PChar; Len: Integer); begin if Len > 255 then Move(Src^, Dst[1], 255) else Move(Src^, Dst[1], Len); SetLength(Dst, Len); end; {$ENDIF} end. |
Цвет строкой
В модуле graphics имеются две недокументированные функции:
| function ColorToString(Color: TColor): string; |
Если значение TColor является именованным цветом, функция возвращает имя цвета ("clRed"). В противном случае возвращается шестнадцатиричное значение цвета в виде строки.
| function StringToColor(S: string): TColor; |
Данная функция преобразует "clRed" или "$0000FF" во внутреннее значение цвета.
- Scott Samet [000858]
Действительно БЫСТРОЕ преобразование сигнала в спекр и обратно (методы Хартли, Фурье и классический)
Публикую присланный читателем алгоритм:
|
{$A+,B-,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+ ,Z1} {$MINSTACKSIZE $00004000} {$MAXSTACKSIZE $00100000} {$IMAGEBASE $00400000} {$APPTYPE GUI} unit Main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, ExtCtrls, ComCtrls, Menus; type TfmMain = class(TForm) MainMenu1: TMainMenu; N1: TMenuItem; N2: TMenuItem; StatusBar1: TStatusBar; N3: TMenuItem; imgInfo: TImage; Panel1: TPanel; btnStart: TSpeedButton; procedure btnStartClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); end; var fmMain: TfmMain; implementation Uses PFiles; {$R *.DFM} function Power2(lPower: Byte): LongInt; begin Result := 1 Shl lPower; end; procedure ClassicDirect(Var aSignal, aSpR, aSpI: Array Of Double; N: LongInt); var lSrch : LongInt; var lGarm : LongInt; var dSumR : Double; var dSumI : Double; begin for lGarm := 0 to N div 2 - 1 do begin dSumR := 0; dSumI := 0; for lSrch := 0 to N - 1 do begin dSumR := dSumR + aSignal[lSrch] * Cos(lGarm * lSrch / N * 2 * PI); dSumI := dSumI + aSignal[lSrch] * Sin(lGarm * lSrch / N * 2 * PI); end; aSpR[lGarm] := dSumR; aSpI[lGarm] := dSumI; end; end; procedure ClassicInverce(Var aSpR, aSpI, aSignal: Array Of Double; N: LongInt); var lSrch : LongInt; var lGarm : LongInt; var dSum : Double; begin for lSrch := 0 to N-1 do begin dSum := 0; for lGarm := 0 to N div 2 -1 do dSum := dSum + aSpR[lGarm] * Cos(lSrch * lGarm * 2 * Pi / N) + aSpI[lGarm] * Sin(lSrch * lGarm * 2 * Pi / N); aSignal[lSrch] := dSum*2; end; end; Function InvertBits(BF, DataSize, Power: Word) : Word; Var BR : Word; Var NN : Word; Var L : Word; Begin br:= 0; nn:= DataSize; For l:= 1 To Power Do Begin NN:= NN Div 2; If (BF >= NN) Then Begin BR:= BR + Power2(l - 1); BF:= BF - NN End; End; InvertBits:=BR; End; Procedure FourierDirect(Var RealData,VirtData,ResultR,ResultV: Array Of Double; DataSize: LongInt); Var A1 : Real; Var A2 : Real; Var B1 : Real; Var B2 : Real; Var D2 : Word; Var C2 : Word; Var C1 : Word; Var D1 : Word; Var I : Word; Var J : Word; Var K : Word; Var Cosin : Real; Var Sinus : Real; Var wIndex : Word; Var Power : Word; Begin C1:= DataSize Shr 1; C2:= 1; for Power:=0 to 15 //hope it will be faster then round(ln(DataSize)/ln(2)) do if Power2(Power)=DataSize then Break; For I:= 1 To Power Do Begin D1:= 0; D2:= C1; For J:= 1 To C2 Do Begin wIndex:=InvertBits(D1 Div C1, DataSize, Power); Cosin:= +(Cos((2 * Pi / DataSize)*wIndex)); Sinus:= -(Sin((2 * Pi / DataSize)*wIndex)); For K:= D1 To D2 - 1 Do Begin A1:= RealData[K]; A2:= VirtData[K]; B1:= ((Cosin * RealData[K + C1] - Sinus * VirtData[K + C1]) ); B2:= ((Sinus * RealData[K + C1] + Cosin * VirtData[K + C1]) ); RealData[K]:= A1 + B1 ; VirtData[K]:= A2 + B2 ; RealData[K + C1]:= A1 - B1; VirtData[K + C1]:= A2 - B2; End; Inc(D1,C1 * 2); Inc(D2,C1 * 2); End; C1:=C1 Div 2; C2:=C2 * 2; End; For I:= 0 To DataSize Div 2 -1 Do Begin ResultR[I]:= + RealData[InvertBits(I, DataSize, Power)]; ResultV[I]:= - VirtData[InvertBits(I, DataSize, Power)]; End; End; Procedure Hartley(iSize: LongInt;Var aData : Array Of Double); Type taDouble = Array[0..MaxLongInt Div SizeOf(Double)-1] Of Double; Var prFI,prFN,prGI : ^taDouble; Var rCos,rSin : Double; Var rA,rB,rTemp : Double; Var rC1,rC2,rC3,rC4 : Double; Var rS1,rS2,rS3,rS4 : Double; Var rF0,rF1,rF2,rF3 : Double; Var rG0,rG1,rG2,rG3 : Double; Var iK1,iK2,iK3,iK4 : LongInt; Var iSrch,iK,iKX : LongInt; Begin iK2:=0; For iK1:=1 To iSize-1 Do Begin iK:=iSize Shr 1; Repeat iK2:=iK2 Xor iK; If (iK2 And iK)<>0 Then Break; iK:=iK Shr 1; Until False; If iK1>iK2 Then Begin rTemp:=aData[iK1]; aData[iK1]:=aData[iK2]; aData[iK2]:=rTemp; End; End; iK:=0; While (1 Shl iK)<iSize Do Inc(iK); iK:=iK And 1; If iK=0 Then Begin prFI:=@aData; prFN:=@aData; prFN := @prFN[iSize]; While Word(prFI)<Word(prFN) Do Begin rF1:=prFI^[0]-prFI^[1]; rF0:=prFI^[0]+prFI^[1]; rF3:=prFI^[2]-prFI^[3]; rF2:=prFI^[2]+prFI^[3]; prFI^[2]:=rF0-rF2; prFI^[0]:=rF0+rF2; prFI^[3]:=rF1-rF3; prFI^[1]:=rF1+rF3; prFI := @prFI[4]; End; End Else Begin prFI:=@aData; prFN:=@aData; prFN := @prFN[iSize]; prGI:=prFI; prGI := @prGI[1]; While Word(prFI)<Word(prFN) Do begin rC1:=prFI^[0]-prGI^[0]; rS1:=prFI^[0]+prGI^[0]; rC2:=prFI^[2]-prGI^[2]; rS2:=prFI^[2]+prGI^[2]; rC3:=prFI^[4]-prGI^[4]; rS3:=prFI^[4]+prGI^[4]; rC4:=prFI^[6]-prGI^[6]; rS4:=prFI^[6]+prGI^[6]; rF1:=rS1-rS2; rF0:=rS1+rS2; rG1:=rC1-rC2; rG0:=rC1+rC2; rF3:=rS3-rS4; rF2:=rS3+rS4; rG3:=Sqrt(2)*rC4; rG2:=Sqrt(2)*rC3; prFI^[4]:=rF0-rF2; prFI^[0]:=rF0+rF2; prFI^[6]:=rF1-rF3; prFI^[2]:=rF1+rF3; prGI^[4]:=rG0-rG2; prGI^[0]:=rG0+rG2; prGI^[6]:=rG1-rG3; prGI^[2]:=rG1+rG3; prFI := @prFI[8]; prGI := @prGI[8]; End; End; If iSize<16 Then Exit; Repeat Inc(iK,2); iK1:=1 Shl iK; iK2:=iK1 Shl 1; iK4:=iK2 Shl 1; iK3:=iK2+iK1; iKX:=iK1 Shr 1; prFI:=@aData; prGI:=prFI; prGI := @prGI[iKX]; prFN:=@aData; prFN := @prFN[iSize]; Repeat rF1:= prFI^[000]-prFI^[iK1]; rF0:= prFI^[000]+prFI^[iK1]; rF3:= prFI^[iK2]-prFI^[iK3]; rF2:= prFI^[iK2]+prFI^[iK3]; prFI^[iK2]:=rF0-rF2; prFI^[000]:=rF0+rF2; prFI^[iK3]:=rF1-rF3; prFI^[iK1]:=rF1+rF3; rG1:=prGI^[0]-prGI^[iK1]; rG0:=prGI^[0]+prGI^[iK1]; rG3:=Sqrt(2)*prGI^[iK3]; rG2:=Sqrt(2)*prGI^[iK2]; prGI^[iK2]:=rG0-rG2; prGI^[000]:=rG0+rG2; prGI^[iK3]:=rG1-rG3; prGI^[iK1]:=rG1+rG3; prGI := @prGI[iK4]; prFI := @prFI[iK4]; Until Not (Word(prFI)<Word(prFN)); rCos:=Cos(Pi/2/Power2(iK)); rSin:=Sin(Pi/2/Power2(iK)); rC1:=1; rS1:=0; For iSrch:=1 To iKX-1 Do Begin rTemp:=rC1; rC1:=(rTemp*rCos-rS1*rSin); rS1:=(rTemp*rSin+rS1*rCos); rC2:=(rC1*rC1-rS1*rS1); rS2:=(2*(rC1*rS1)); prFN:=@aData; prFN := @prFN[iSize]; prFI:=@aData; prFI := @prFI[iSrch]; prGI:=@aData; prGI := @prGI[iK1-iSrch]; Repeat rB:=(rS2*prFI^[iK1]-rC2*prGI^[iK1]); rA:=(rC2*prFI^[iK1]+rS2*prGI^[iK1]); rF1:=prFI^[0]-rA; rF0:=prFI^[0]+rA; rG1:=prGI^[0]-rB; rG0:=prGI^[0]+rB; rB:=(rS2*prFI^[iK3]-rC2*prGI^[iK3]); rA:=(rC2*prFI^[iK3]+rS2*prGI^[iK3]); rF3:=prFI^[iK2]-rA; rF2:=prFI^[iK2]+rA; rG3:=prGI^[iK2]-rB; rG2:=prGI^[iK2]+rB; rB:=(rS1*rF2-rC1*rG3); rA:=(rC1*rF2+rS1*rG3); prFI^[iK2]:=rF0-rA; prFI^[0]:=rF0+rA; prGI^[iK3]:=rG1-rB; prGI^[iK1]:=rG1+rB; rB:=(rC1*rG2-rS1*rF3); rA:=(rS1*rG2+rC1*rF3); prGI^[iK2]:=rG0-rA; prGI^[0]:=rG0+rA; prFI^[iK3]:=rF1-rB; prFI^[iK1]:=rF1+rB; prGI := @prGI[iK4]; prFI := @prFI[iK4]; Until Not (LongInt(prFI) < LongInt(prFN)); End; Until Not (iK4<iSize); End; Procedure HartleyDirect( Var aData : Array Of Double; iSize : LongInt); Var rA,rB : Double; Var iI,iJ,iK : LongInt; Begin Hartley(iSize,aData); iJ:=iSize-1; iK:=iSize Div 2; For iI:=1 To iK-1 Do Begin rA:=aData[ii]; rB:=aData[ij]; aData[iJ]:=(rA-rB)/2; aData[iI]:=(rA+rB)/2; Dec(iJ); End; End; Procedure HartleyInverce( Var aData : Array Of Double; iSize : LongInt); Var rA,rB : Double; Var iI,iJ,iK : LongInt; Begin iJ:=iSize-1; iK:=iSize Div 2; For iI:=1 To iK-1 Do Begin rA:=aData[iI]; rB:=aData[iJ]; aData[iJ]:=rA-rB; aData[iI]:=rA+rB; Dec(iJ); End; Hartley(iSize,aData); End; //not tested procedure HartleyDirectComplex(real,imag: Array of Double;n: LongInt); var a,b,c,d : double; q,r,s,t : double; i,j,k : LongInt; begin j:=n-1; k:=n div 2; for i:=1 to k-1 do begin a := real[i]; b := real[j]; q:=a+b; r:=a-b; c := imag[i]; d := imag[j]; s:=c+d; t:=c-d; real[i] := (q+t)*0.5; real[j] := (q-t)*0.5; imag[i] := (s-r)*0.5; imag[j] := (s+r)*0.5; dec(j); end; Hartley(N,Real); Hartley(N,Imag); end; //not tested procedure HartleyInverceComplex(real,imag: Array Of Double;N: LongInt); var a,b,c,d :double; q,r,s,t :double; i,j,k :longInt; begin Hartley(N,real); Hartley(N,imag); j:=n-1; k:=n div 2; for i:=1 to k-1 do begin a := real[i]; b := real[j]; q:=a+b; r:=a-b; c := imag[i]; d := imag[j]; s:=c+d; t:=c-d; imag[i] := (s+r)*0.5; imag[j] := (s-r)*0.5; real[i] := (q-t)*0.5; real[j] := (q+t)*0.5; dec(j); end; end; procedure DrawSignal(var aSignal: Array Of Double;N,lColor : LongInt); var lSrch : LongInt; var lHalfHeight : LongInt; begin with fmMain do begin lHalfHeight := imgInfo.Height Div 2; imgInfo.Canvas.MoveTo(0,lHalfHeight); imgInfo.Canvas.Pen.Color := lColor; for lSrch := 0 to N-1 do begin imgInfo.Canvas.LineTo(lSrch,Round(aSignal[lSrch]) + lHalfHeight); end; imgInfo.Repaint; end; end; procedure DrawSpector(var aSpR, aSpI: Array Of Double;N, lColR, lColI : LongInt); var lSrch : LongInt; var lHalfHeight : LongInt; begin with fmMain do begin lHalfHeight := imgInfo.Height Div 2; for lSrch := 0 to N Div 2 do begin imgInfo.Canvas.Pixels[lSrch ,Round(aSpR[lSrch]/N) + lHalfHeight] := lColR; imgInfo.Canvas.Pixels[lSrch + N Div 2 ,Round(aSpI[lSrch]/N) + lHalfHeight] := lColI; end; imgInfo.Repaint; end; end; const N = 512; var aSignalR : Array[0..N-1] Of Double;// var aSignalI : Array[0..N-1] Of Double;// var aSpR, aSpI : Array[0..N Div 2-1] Of Double;// var lFH : LongInt; procedure TfmMain.btnStartClick(Sender: TObject); const Epsilon = 0.00001; var lSrch : LongInt; var aBuff : Array[0..N-1] Of ShortInt; begin if lFH > 0 then begin // Repeat if F.Read(lFH,@aBuff,N) <> N then begin Exit; end; for lSrch := 0 to N-1 do begin aSignalR[lSrch] := ShortInt(aBuff[lSrch]+$80); aSignalI[lSrch] := 0; end; imgInfo.Canvas.Rectangle(0,0,imgInfo.Width,imgInfo.Height); DrawSignal(aSignalR, N, $D0D0D0); // ClassicDirect(aSignalR, aSpR, aSpI, N); //result in aSpR & aSpI, aSignal unchanged // FourierDirect(aSignalR, aSignalI, aSpR, aSpI, N); //result in aSpR & aSpI, aSiggnalR & aSignalI modified HartleyDirect(aSignalR, N); //result in source aSignal ;-) DrawSpector(aSignalR, aSignalR[N Div 2 -1], N, $80, $8000); DrawSpector(aSpR, aSpI, N, $80, $8000); { for lSrch := 0 to N div 2 -1 do begin //comparing classic & Hartley if (Abs(aSpR[lSrch] - aSignal[lSrch]) > Epsilon) or ((lSrch > 0) And (Abs(aSpI[lSrch] - aSignal[N - lSrch]) > Epsilon)) then MessageDlg('Error comparing',mtError,[mbOK],-1); end;} HartleyInverce(aSignalR, N); //to restore original signal with HartleyDirect // ClassicInverce(aSpR, aSpI, aSignalR, N); //to restore original signal with ClassicDirect or FourierDirect for lSrch := 0 to N -1 do aSignalR[lSrch]:= aSignalR[lSrch]/N; //scaling DrawSignal(aSignalR, N, $D00000); Application.ProcessMessages; // Until False; end; end; procedure TfmMain.FormCreate(Sender: TObject); begin lFH := F.Open('input.pcm', ForRead); end; procedure TfmMain.FormClose(Sender: TObject; var Action: TCloseAction); begin F.Close(lFH); end; end. |
Denis Furman [000705]
Декомпилляция звукового файла формата Wave и получение звуковых данных
Интересно, есть ли технология преобразования Wave-формата в обычный набор звуковых данных? К примеру, мне необходимо удалить заголовок и механизм (метод) сжатия, которые могут компилироваться и сохраняться вместе с Wave-файлами.
У меня есть программа под D1/D2, которая читает WAV-файлы и вытаскивает исходные данные, но она не может их восстанавить, используя зашитый алгоритм сжатия.
|
unit LinearSystem; interface {============== Тип, описывающий формат WAV ==================} type WAVHeader = record nChannels : Word; nBitsPerSample : LongInt; nSamplesPerSec : LongInt; nAvgBytesPerSec : LongInt; RIFFSize : LongInt; fmtSize : LongInt; formatTag : Word; nBlockAlign : LongInt; DataSize : LongInt; end; {============== Поток данных сэмпла ========================} const MaxN = 300; { максимальное значение величины сэмпла } type SampleIndex = 0 .. MaxN+3; type DataStream = array[ SampleIndex ] of Real; var N : SampleIndex; {============== Переменные сопровождения ======================} type Observation = record Name : String[40]; {Имя данного сопровождения} yyy : DataStream; {Массив указателей на данные} WAV : WAVHeader; {Спецификация WAV для сопровождения} Last : SampleIndex; {Последний доступный индекс yyy} MinO, MaxO : Real; {Диапазон значений yyy} end; var K0R, K1R, K2R, K3R : Observation; K0B, K1B, K2B, K3B : Observation; {================== Переменные имени файла ===================} var StandardDatabase : String[ 80 ]; BaseFileName : String[ 80 ]; StandardOutput : String[ 80 ]; StandardInput : String[ 80 ]; {=============== Объявления процедур ==================} procedure ReadWAVFile (var Ki, Kj : Observation); procedure WriteWAVFile (var Ki, Kj : Observation); procedure ScaleData (var Kk : Observation); procedure InitAllSignals; procedure InitLinearSystem; implementation {$R *.DFM} uses VarGraph, SysUtils; {================== Стандартный формат WAV-файла ===================} const MaxDataSize : LongInt = (MaxN+1)*2*2; const MaxRIFFSize : LongInt = (MaxN+1)*2*2+36; const StandardWAV : WAVHeader = ( nChannels : Word(2); nBitsPerSample : LongInt(16); nSamplesPerSec : LongInt(8000); nAvgBytesPerSec : LongInt(32000); RIFFSize : LongInt((MaxN+1)*2*2+36); fmtSize : LongInt(16); formatTag : Word(1); nBlockAlign : LongInt(4); DataSize : LongInt((MaxN+1)*2*2) ); {================== Сканирование переменных сопровождения ===================} |
procedure ScaleData(var Kk : Observation);
var I : SampleIndex;
begin
{Инициализация переменных сканирования}
Kk.MaxO := Kk.yyy[0];
Kk.MinO := Kk.yyy[0];
{Сканирование для получения максимального и минимального значения}
for I := 1 to Kk.Last do
begin
if Kk.MaxO < Kk.yyy[I] then Kk.MaxO := Kk.yyy[I];
if Kk.MinO > Kk.yyy[I] then Kk.MinO := Kk.yyy[I];
end;
end; { ScaleData }
procedure ScaleAllData;
begin
ScaleData(K0R);
ScaleData(K0B);
ScaleData(K1R);
ScaleData(K1B);
ScaleData(K2R);
ScaleData(K2B);
ScaleData(K3R);
ScaleData(K3B);
end; {ScaleAllData}
{================== Считывание/запись WAV-данных ===================}
VAR InFile, OutFile : file of Byte;
type Tag = (F0, T1, M1);
type FudgeNum = record
case X:Tag of
F0 : (chrs : array[0..3] of Byte);
T1 : (lint : LongInt);
M1 : (up,dn: Integer);
end;
var ChunkSize : FudgeNum;
procedure WriteChunkName(Name:String);
var i : Integer;
MM : Byte;
begin
for i := 1 to 4 do
begin
MM := ord(Name[i]);
write(OutFile,MM);
end;
end; {WriteChunkName}
procedure WriteChunkSize(LL:Longint);
var I : integer;
begin
ChunkSize.x:=T1;
ChunkSize.lint:=LL;
ChunkSize.x:=F0;
for I := 0 to 3 do Write(OutFile,ChunkSize.chrs[I]);
end;
procedure WriteChunkWord(WW:Word);
var I : integer;
begin
ChunkSize.x:=T1;
ChunkSize.up:=WW;
ChunkSize.x:=M1;
for I := 0 to 1 do Write(OutFile,ChunkSize.chrs[I]);
end; {WriteChunkWord}
procedure WriteOneDataBlock(var Ki, Kj : Observation);
var I : Integer;
begin
ChunkSize.x:=M1;
with Ki.WAV do
begin
case nChannels of
1:if nBitsPerSample=16
then begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
ChunkSize.up := trunc(Ki.yyy[N]+0.5);
if N<MaxN then ChunkSize.dn := trunc(Ki.yyy[N+1]+0.5);
N := N+2;
end
else begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}
for I:=0 to 3 do ChunkSize.chrs[I]
:= trunc(Ki.yyy[N+I]+0.5);
N := N+4;
end;
2:if nBitsPerSample=16
then begin {2 Двухканальный 16-битный сэмпл}
ChunkSize.dn := trunc(Ki.yyy[N]+0.5);
ChunkSize.up := trunc(Kj.yyy[N]+0.5);
N := N+1;
end
else begin {4 Двухканальный 8-битный сэмпл}
ChunkSize.chrs[1] := trunc(Ki.yyy[N]+0.5);
ChunkSize.chrs[3] := trunc(Ki.yyy[N+1]+0.5);
ChunkSize.chrs[0] := trunc(Kj.yyy[N]+0.5);
ChunkSize.chrs[2] := trunc(Kj.yyy[N+1]+0.5);
N := N+2;
end;
end; {with WAV do begin..}
end; {четырехбайтовая переменная "ChunkSize" теперь заполнена}
ChunkSize.x:=T1;
WriteChunkSize(ChunkSize.lint);{помещаем 4 байта данных}
end; {WriteOneDataBlock}
procedure WriteWAVFile(var Ki, Kj : Observation);
var MM : Byte;
I : Integer;
OK : Boolean;
begin
{Приготовления для записи файла данных}
AssignFile(OutFile, StandardOutput); { Файл, выбранный в диалоговом окне }
ReWrite( OutFile );
With Ki.WAV do
begin DataSize := nChannels*(nBitsPerSample div 8)*(Ki.Last+1);
RIFFSize := DataSize+36;
fmtSize := 16;
end;
{Записываем ChunkName "RIFF"}
WriteChunkName('RIFF');
{Записываем ChunkSize}
WriteChunkSize(Ki.WAV.RIFFSize);
{Записываем ChunkName "WAVE"}
WriteChunkName('WAVE');
{Записываем tag "fmt_"}
WriteChunkName('fmt ');
{Записываем ChunkSize}
Ki.WAV.fmtSize := 16; {должно быть 16-18}
WriteChunkSize(Ki.WAV.fmtSize);
{Записываем formatTag, nChannels}
WriteChunkWord(Ki.WAV.formatTag);
WriteChunkWord(Ki.WAV.nChannels);
{Записываем nSamplesPerSec}
WriteChunkSize(Ki.WAV.nSamplesPerSec);
{Записываем nAvgBytesPerSec}
WriteChunkSize(Ki.WAV.nAvgBytesPerSec);
{Записываем nBlockAlign, nBitsPerSample}
WriteChunkWord(Ki.WAV.nBlockAlign);
WriteChunkWord(Ki.WAV.nBitsPerSample);
{Записываем метку блока данных "data"}
WriteChunkName('data');
{Записываем DataSize}
WriteChunkSize(Ki.WAV.DataSize);
N:=0; {первая запись-позиция}
while N<=Ki.Last do WriteOneDataBlock(Ki,Kj); {помещаем 4 байта и увеличиваем счетчик N}
{Освобождаем буфер файла}
CloseFile( OutFile );
end; {WriteWAVFile}
procedure InitSpecs;
begin
end; { InitSpecs }
procedure InitSignals(var Kk : Observation);
var J : Integer;
begin
for J := 0 to MaxN do Kk.yyy[J] := 0.0;
Kk.MinO := 0.0;
Kk.MaxO := 0.0;
Kk.Last := MaxN;
end; {InitSignals}
procedure InitAllSignals;
begin
InitSignals(K0R);
InitSignals(K0B);
InitSignals(K1R);
InitSignals(K1B);
InitSignals(K2R);
InitSignals(K2B);
InitSignals(K3R);
InitSignals(K3B);
end; {InitAllSignals}
var ChunkName : string[4];
procedure ReadChunkName;
var I : integer;
MM : Byte;
begin
ChunkName[0]:=chr(4);
for I := 1 to 4 do
begin
Read(InFile,MM);
ChunkName[I]:=chr(MM);
end;
end; {ReadChunkName}
procedure ReadChunkSize;
var I : integer;
MM : Byte;
begin
ChunkSize.x := F0;
ChunkSize.lint := 0;
for I := 0 to 3 do
begin
Read(InFile,MM);
ChunkSize.chrs[I]:=MM;
end;
ChunkSize.x := T1;
end; {ReadChunkSize}
procedure ReadOneDataBlock(var Ki,Kj:Observation);
var I : Integer;
begin
if N<=MaxN then
begin
ReadChunkSize; {получаем 4 байта данных}
ChunkSize.x:=M1;
with Ki.WAV do
case nChannels of
1:if nBitsPerSample=16
then begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
Ki.yyy[N] :=1.0*ChunkSize.up;
if N<MaxN then Ki.yyy[N+1]:=1.0*ChunkSize.dn;
N := N+2;
end
else begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}
for I:=0 to 3 do Ki.yyy[N+I]:=1.0*ChunkSize.chrs[I];
N := N+4;
end;
2:if nBitsPerSample=16
then begin {2 Двухканальный 16-битный сэмпл}
Ki.yyy[N]:=1.0*ChunkSize.dn;
Kj.yyy[N]:=1.0*ChunkSize.up;
N := N+1;
end
else begin {4 Двухканальный 8-битный сэмпл}
Ki.yyy[N] :=1.0*ChunkSize.chrs[1];
Ki.yyy[N+1]:=1.0*ChunkSize.chrs[3];
Kj.yyy[N] :=1.0*ChunkSize.chrs[0];
Kj.yyy[N+1]:=1.0*ChunkSize.chrs[2];
N := N+2;
end;
end;
if N<=MaxN then begin {LastN := N;}
Ki.Last := N;
if Ki.WAV.nChannels=2 then Kj.Last := N;
end
else begin {LastN := MaxN;}
Ki.Last := MaxN;
if Ki.WAV.nChannels=2 then Kj.Last := MaxN;
end;
end;
end; {ReadOneDataBlock}
procedure ReadWAVFile(var Ki, Kj :Observation);
var MM : Byte;
I : Integer;
OK : Boolean;
NoDataYet : Boolean;
DataYet : Boolean;
nDataBytes : LongInt;
begin
if FileExists(StandardInput)
then
with Ki.WAV do
begin { Вызов диалога открытия файла }
OK := True; {если не изменится где-нибудь ниже}
{Приготовления для чтения файла данных}
AssignFile(InFile, StandardInput); { Файл, выбранный в диалоговом окне }
Reset( InFile );
{Считываем ChunkName "RIFF"}
ReadChunkName;
if ChunkName<>'RIFF' then OK := False;
{Считываем ChunkSize}
ReadChunkSize;
RIFFSize := ChunkSize.lint; {должно быть 18,678}
{Считываем ChunkName "WAVE"}
ReadChunkName;
if ChunkName<>'WAVE' then OK := False;
{Считываем ChunkName "fmt_"}
ReadChunkName;
if ChunkName<>'fmt ' then OK := False;
{Считываем ChunkSize}
ReadChunkSize;
fmtSize := ChunkSize.lint; {должно быть 18}
{Считываем formatTag, nChannels}
ReadChunkSize;
ChunkSize.x := M1;
formatTag := ChunkSize.up;
nChannels := ChunkSize.dn;
{Считываем nSamplesPerSec}
ReadChunkSize;
nSamplesPerSec := ChunkSize.lint;
{Считываем nAvgBytesPerSec}
ReadChunkSize;
nAvgBytesPerSec := ChunkSize.lint;
{Считываем nBlockAlign}
ChunkSize.x := F0;
ChunkSize.lint := 0;
for I := 0 to 3 do
begin Read(InFile,MM);
ChunkSize.chrs[I]:=MM;
end;
ChunkSize.x := M1;
nBlockAlign := ChunkSize.up;
{Считываем nBitsPerSample}
nBitsPerSample := ChunkSize.dn;
for I := 17 to fmtSize do Read(InFile,MM);
NoDataYet := True;
while NoDataYet do
begin
{Считываем метку блока данных "data"}
ReadChunkName;
{Считываем DataSize}
ReadChunkSize;
DataSize := ChunkSize.lint;
if ChunkName<>'data' then
begin
for I := 1 to DataSize do {пропуск данных, не относящихся к набору звуковых данных}
Read(InFile,MM);
end
else NoDataYet := False;
end;
nDataBytes := DataSize;
{Наконец, начинаем считывать данные для байтов nDataBytes}
if nDataBytes>0 then DataYet := True;
N:=0; {чтение с первой позиции}
while DataYet do
begin
ReadOneDataBlock(Ki,Kj); {получаем 4 байта}
nDataBytes := nDataBytes-4;
if nDataBytes<=4 then DataYet := False;
end;
ScaleData(Ki);
if Ki.WAV.nChannels=2
then begin Kj.WAV := Ki.WAV;
ScaleData(Kj);
end;
{Освобождаем буфер файла}
CloseFile( InFile );
end
else begin
InitSpecs;{файл не существует}
InitSignals(Ki);{обнуляем массив "Ki"}
InitSignals(Kj);{обнуляем массив "Kj"}
end;
end; { ReadWAVFile }
{================= Операции с набором данных ====================}
const MaxNumberOfDataBaseItems = 360;
type SignalDirectoryIndex = 0 .. MaxNumberOfDataBaseItems;
VAR DataBaseFile : file of Observation;
LastDataBaseItem : LongInt; {Номер текущего элемента набора данных}
ItemNameS : array[SignalDirectoryIndex] of String[40];
procedure GetDatabaseItem( Kk : Observation; N : LongInt );
begin
if N<=LastDataBaseItem
then begin
Seek(DataBaseFile, N);
Read(DataBaseFile, Kk);
end
else InitSignals(Kk);
end; {GetDatabaseItem}
procedure PutDatabaseItem( Kk : Observation; N : LongInt );
begin
if N<MaxNumberOfDataBaseItems
then
if N<=LastDataBaseItem
then begin
Seek(DataBaseFile, N);
Write(DataBaseFile, Kk);
LastDataBaseItem := LastDataBaseItem+1;
end
else while LastDataBaseItem<=N do
begin
Seek(DataBaseFile, LastDataBaseItem);
Write(DataBaseFile, Kk);
LastDataBaseItem := LastDataBaseItem+1;
end
else ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems}
end; {PutDatabaseItem}
procedure InitDataBase;
begin
LastDataBaseItem := 0;
if FileExists(StandardDataBase)
then
begin
Assign(DataBaseFile,StandardDataBase);
Reset(DataBaseFile);
while not EOF(DataBaseFile) do
begin
GetDataBaseItem(K0R, LastDataBaseItem);
ItemNameS[LastDataBaseItem] := K0R.Name;
LastDataBaseItem := LastDataBaseItem+1;
end;
if EOF(DataBaseFile)
then if LastDataBaseItem>0
then LastDataBaseItem := LastDataBaseItem-1;
end;
end; {InitDataBase}
function FindDataBaseName( Nstg : String ):LongInt;
var ThisOne : LongInt;
begin
ThisOne := 0;
FindDataBaseName := -1;
while ThisOne<LastDataBaseItem do
begin
if Nstg=ItemNameS[ThisOne]
then begin
FindDataBaseName := ThisOne;
Exit;
end;
ThisOne := ThisOne+1;
end;
end; {FindDataBaseName}
{======================= Инициализация модуля ========================}
procedure InitLinearSystem;
begin
BaseFileName := '\PROGRA~1\SIGNAL~1\';
StandardOutput := BaseFileName + 'K0.wav';
StandardInput := BaseFileName + 'K0.wav';
StandardDataBase := BaseFileName + 'Radar.sdb';
InitAllSignals;
InitDataBase;
ReadWAVFile(K0R,K0B);
ScaleAllData;
end; {InitLinearSystem}
begin {инициализируемый модулем код}
InitLinearSystem;
end. {Unit LinearSystem}
[000008]
Есть ли функция, выполняющая пpеобpазование пеpеменной real в integer?
Nomadic советует:
Hа самом деле есть две функции - Round и Trunc (округление и отсечение дробной части соответственно).
Кстати, функции эти были уже в самых ранних версиях Паскаля. Так что мой совет - изучите Паскаль - полезно.
Hy, если yж дело идет к изyчению списка фyнкций :), то yпомянy еще Ceil и Floor. Unit Math;
Кстати, втоpая из них мне очень пpигодилась для полyчения экспоненты числа. Имеется в видy экспонента: X=1E 13 [001193]
Как перевести полярные величины в линейные (радианы в градусы)?
Своим опытом делится Олег Кулабухов:
|
procedure TForm1.Button1Click(Sender: TObject); var Angle : Double; x : Double; y : Double; Distance : Double; Radians : Double; begin Distance := 100; Angle := 270; Radians := Angle * DegToRad; x := Round(Distance * Cos(Radians)); y := Round(Distance * Sin(Radians)); ShowMessage(FloatToStr(x) + ' ' + FloatToStr(y)); end; |
[001911]
Как представить строку из 0 и 1 в числовом виде?
Своим опытом делится Олег Кулабухов:
Нижеприведенный пример переводит строку в longint.
|
function BinStringToLongInt(BinString : string) : longint; var i : integer; Num : longint; begin Num := 0; for i := 1 to length(BinString) do if BinString[i] = '1' then Num := (Num shl 1) + 1 else Num := (Num shl 1); Result := Num; end; procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Lines.Add(IntToStr(BinStringToLongInt('11111111'))); end; |
[001903]
Перекодировка текста
Публикую присланное читателем письмо:
Недавно меня озадачили. Попросили написать программу которая переводит текст из кодировки Dos в Windows и наоборот. Я немного покопался в help'е и вот что у меня получилось. Я надеюсь вас заинтересует мое решение.
|
procedure MyOemToChar; var b:string; begin b:=Memo1.Lines.Text; OemToChar(PChar(b),Pchar(b)); Memo2.Lines.Text:=b; end; |
или
|
procedure MyOemToChar; var b:PChar; begin b:=Memo1.Lines.GetText; OemToChar(b,b); Memo2.Lines.Text:=StrPas(b); end; |
Я сам предпочитаю использовать вариант N1. Хотя во время тестирования оба варианта работали.
Всего наилучшего. Виталий Еремеев. [000703]
Перевод из BitMap в Icon
...(Ваша старая программа вроде не работает) Нужно создать два bitmap, маску (называемую "AND") и bitmap с картинкой (называемый "XOR" bitmap). Можно передать handles к "AND" и "XOR" bitmap Windows API функции CreateIconIndirect() ииспользовать полученный handle иконки в вашем приложении
|
procedure TForm1.Button1Click(Sender: TObject); var IconSizeX : integer; IconSizeY : integer; AndMask : TBitmap; XOrMask : TBitmap; IconInfo : TIconInfo; Icon : TIcon; begin {Получаем размеры иконки} IconSizeX := GetSystemMetrics(SM_CXICON); IconSizeY := GetSystemMetrics(SM_CYICON); {создаем маску "And"} AndMask := TBitmap.Create; AndMask.Monochrome := true; AndMask.Width := IconSizeX; AndMask.Height := IconSizeY; {рисуем на маске "And"} AndMask.Canvas.Brush.Color := clWhite; AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); AndMask.Canvas.Brush.Color := clBlack; AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Рисуем для проверки} Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); {Создаем маску "XOr"} XOrMask := TBitmap.Create; XOrMask.Width := IconSizeX; XOrMask.Height := IconSizeY; {Рисуем на маске "XOr"} XOrMask.Canvas.Brush.Color := ClBlack; XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); XOrMask.Canvas.Pen.Color := clRed; XOrMask.Canvas.Brush.Color := clRed; XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Рисуем для проверки} Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); {Создаем иконку} Icon := TIcon.Create; IconInfo.fIcon := true; IconInfo.xHotspot := 0; IconInfo.yHotspot := 0; IconInfo.hbmMask := AndMask.Handle; IconInfo.hbmColor := XOrMask.Handle; Icon.Handle := CreateIconIndirect(IconInfo); {Удаляем временные bitmap} AndMask.Free; XOrMask.Free; {Рисуем для проверки} Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); {Присвамваем иконку приложению} Application.Icon := Icon; {Заставляем перерисоваться} InvalidateRect(Application.Handle, nil, true); {Освобождаем иконку} Icon.Free; end; |
Прислал Alexander Vozny. [000461]
Почему непpавильно pаботает функция StrToFloat?
Nomadic советует:
Пишу даже прямо StrToFloat('32.34'), к примеру, получаю исключение "'32.34' is not valid float". Если пишу число без десятичной точки, то все ОК. А какой у тебя DecimalSeparator? В Russian settings почему-то по умолчанию считается, что разделитеь дроби - запятая. Пеpеустанови пpи запуске пpогpаммы
| DecimalSeparator := '.'; |
Или пользуйся этой функцией так:
| StrToFloat('32,24'); |
[001201]
Преобразование '1010' в '001010'
Решением является создание функции, функционально похожей на функцию Clipper - PadL(string,width,character):
|
function TfrmFunc.PadL(cVal: string; nWide: integer; cChr: char): string; var i1,nStart: integer; begin if length(cVal) < nWide then begin nStart:=length(cVal); for i1:=nStart to nWide-1 do cVal:=cChar+cVal; end; PadL:=cVal; end; |
Затем это может вызываться c любой строкой, которой вы хотите задать определенную длину. Пользуйтесь функцией также, как вы привыкли пользоваться прежней - PadL(A,length(B),'0'); Она имеет большую гибкость - возможно заполнение любым символом до необходимой длины (удобно для задания текстовых счетчиков с фиксированным количеством символов -- PadL(A,6,'0').
Дополнение
Good_mag пишет:
Мне очень нравится Ваше издание, но вот встретил одно решение, которое не очень мне понравилось. Оно правильное, но довольно длинное.
Вот мой вариант этого решения, он короче предыдущего:
|
function PadL(s_InStr: string; i_Wide: integer; c_Chr: char): string; begin while Length(s_InStr) < i_Wide do s_InStr := c_Chr + s_InStr; Result := s_InStr; end; |
Используя Delphi 3, как мне
Используя Delphi 3, как мне сохранить BMP-изображение в JPEG-файле?
Допустим, Image1 - компонент TImage, содержащий растровое изображение. Используйте следующий фрагмент кода для конвертации вашего изображения в JPEG-файл:
|
var MyJpeg: TJpegImage; Image1: TImage; begin Image1:= TImage.Create; MyJpeg:= TJpegImage.Create; Image1.LoadFromFile('TestImage.BMP'); // Чтение изображения из файла MyJpeg.Assign(Image1.Picture.Bitmap); // Назначание изображения объекту MyJpeg MyJpeg.SaveToFile('MyJPEGImage.JPG'); // Сохранение на диске изображения в формате JPEG end; |
Преобразование дробной и целой части REAL-числа в два целых
Я написал программу, которая делает это. Это DOS-программа. Вы вызываете ее с десятичным числом, передаваемым в качестве параметра. После чего программка выведет 3 колонки, в первой будет находиться исходное число, две остальные будут содержать числитель и знаменатель. Вы можете преобразовать программу в функцию и применять ее в своих приложениях, но, думаю, это несложно, и с этим вы справитесь сами.
Для ее запуска достаточно в подсказке DOS набрать ее имя и число: CONTFRAC 3.141592654
|
program contfrac; { непрерывные дроби } {$N+} const order = 20; var y, lasterr, error, x : extended; a : array[0..order] of longint; i,j, n : integer; op, p, q : longint; begin lasterr := 1e30; val(paramstr(1), y, n); if n <> 0 then halt; x := y; a[0] := trunc(x); writeln; writeln(a[0]:20, a[0]:14, 1:14); { это может вызвать резкую головную боль и галлюцинации } for i := 1 to order do begin x := 1.0 / frac(x); a[i] := trunc(x); p := 1; q := a[i]; for j := pred(i) downto 0 do begin op := p; p := q; q := a[j] * q + op; end; error := abs(y - int(q) / int(p)); if abs(error) >= abs(lasterr) then halt; writeln(a[i]:20, q:14, p:14, error:10); if error < 1e-18 then halt; lasterr := error; end; end. |
Теперь попытаюсь объяснить мой алгоритм (он, по-моему, достаточно быстрый). Вот схема:
Допустим, мы используем число 23.56.
Берем наше натуральное число и производим целочисленное деление на 1.
23.56 div 1 = 23
Теперь вычитаем результат из числа, с которого мы начали.
23.56 - 23 = .56
Для преобразования значения в целое мы просто умножаем его на 100, и, при необходимости, приводим его к целому. valA := (val div 100); valB := (valA - val); or valB := (valA - val) * 100; val = 23.56 ValA = 23 ValB = .56 or 56 [001178]
Преобразование двоичного числа в десятичное
Может ли кто-нибудь дать мне идею простого преобразования двоичного кода (base2) в десятичный (base10)?
Решение 1
|
///////////////////////////////////////////////////////////////////////// // преобразование 32-битного base2 в 32-битный base10 // // максимальное число = 99 999 999, возвращает -1 при большем значении // ///////////////////////////////////////////////////////////////////////// function Base10(Base2:Integer) : Integer; assembler; asm cmp eax,100000000 // проверка максимального значения jb @1 // значение в пределах допустимого mov eax,-1 // флаг ошибки jmp @exit // выход если -1 @1: push ebx // сохранение регистров push esi xor esi,esi // результат = 0 mov ebx,10 // вычисление десятичного логарифма mov ecx,8 // преобразование по формуле 10^8-1 @2: mov edx,0 // удаление разницы div ebx // eax - целочисленное деление на 10, edx - остаток от деления на 10 add esi,edx // результат = результат + разность[I] ror esi,4 // перемещение разряда loop @2 // цикл для всех 8 разрядов mov eax,esi // результат функции pop esi // восстанавление регистров pop ebx @exit: end; |
Решение 2
|
function IntToBin(Value: LongInt;Size: Integer): String; var i: Integer; begin Result:=''; for i:=Size downto 0 do begin if Value and (1 shl i)<>0 then begin Result:=Result+'1'; end else begin Result:=Result+'0'; end; end; end; function BinToInt(Value: String): LongInt; var i,Size: Integer; begin Result:=0; Size:=Length(Value); for i:=Size downto 0 do begin if Copy(Value,i,1)='1' then begin Result:=Result+(1 shl i); end; end; end; |
Решение 3
Следующая функция получает в качестве параметра Base (1..16) любую десятичную величину и возвращает результат в виде строки, содержащей точное значение BaseX. Вы можете использовать данный алгоритм для преобразования арабских чисел в римские (смотри ниже).
|
function DecToBase( Decimal: LongInt; const Base: Byte): String; const Symbols: String[16] = '0123456789ABCDEF'; var scratch: String; remainder: Byte; begin scratch := ''; repeat remainder := Decimal mod Base; scratch := Symbols[remainder + 1] + scratch; Decimal := Decimal div Base; until ( Decimal = 0 ); Result := scratch; end; |
Передайте данной функции любую десятичную величину (1...3999), и она возвратит строку, содержащую точное значение в римской транскрипции.
|
function DecToRoman( Decimal: LongInt ): String; const Romans: Array[1..13] of String = ( 'I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M' ); Arabics: Array[1..13] of Integer = ( 1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000); var i: Integer; scratch: String; begin scratch := ''; for i := 13 downto 1 do while ( Decimal >= Arabics[i] ) do begin Decimal := Decimal - Arabics[i]; scratch := scratch + Romans[i]; end; Result := scratch; end; |
Преобразование ICO в BMP
Решение 1
Попробуйте:
| var Icon : TIcon; Bitmap : TBitmap; begin Icon := TIcon.Create; Bitmap := TBitmap.Create; Icon.LoadFromFile('c:\picture.ico'); Bitmap.Width := Icon.Width; Bitmap.Height := Icon.Height; Bitmap.Canvas.Draw(0, 0, Icon); Bitmap.SaveToFile('c:\picture.bmp'); Icon.Free; Bitmap.Free; end; |
Решение 2
Способ преобразования изображения размером 32x32 в иконку.
|
unit main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,Dialogs,ExtCtrls, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Image1: TImage; Image2: TImage; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var winDC, srcdc, destdc : HDC; oldBitmap : HBitmap; iinfo : TICONINFO; begin GetIconInfo(Image1.Picture.Icon.Handle, iinfo); WinDC := getDC(handle); srcDC := CreateCompatibleDC(WinDC); destDC := CreateCompatibleDC(WinDC); oldBitmap := SelectObject(destDC, iinfo.hbmColor); oldBitmap := SelectObject(srcDC, iinfo.hbmMask); BitBlt(destdc, 0, 0, Image1.picture.icon.width, Image1.picture.icon.height, srcdc, 0, 0, SRCPAINT); Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap); DeleteDC(destDC); DeleteDC(srcDC); DeleteDC(WinDC); image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName) + 'myfile.bmp'); end; procedure TForm1.FormCreate(Sender: TObject); begin image1.picture.icon.loadfromfile('c:\myicon.ico'); end; end. |
Преобразование ICO в BMP II
A.Astafiev@ftc.ru советует:
Чтобы преобразовать Icon в Bitmap используйте TImageList. для обратного преобразования замените метод AddIcon на Add, и метод GetBitmap на GetIcon.
|
function Icon2Bitmap(Icon: TIcon): TBitmap; begin with TImageList.Create (nil) do begin AddIcon (Icon); Result := TBitmap.Create; GetBitmap (0, Result); Free; end; end; |
[000909]
Преобразование ICO в BMP III
|
procedure TIconShow.FileListBox1Click(Sender: TObject); var MyIcon: TIcon; MyBitMap : TBitmap; begin MyIcon := TIcon.Create; MyBitMap := TBitmap.Create; try { получаем имя файла и связанную с ним иконку} strFileName := FileListBox1.Items[FileListBox1.ItemIndex]; StrPCopy(cStrFileName, strFileName); MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0); { рисуем иконку на bitmap в speedbutton } SpeedButton1.Glyph := MyBitMap; SpeedButton1.Glyph.Width := MyIcon.Width; SpeedButton1.Glyph.Height := MyIcon.Height; SpeedButton1.Glyph.Canvas.Draw(0,0, MyIcon); SpeedButton1.Hint := strFileName; finally MyIcon.Free; MyBitMap.Free; end; end; |
[001804]
Преобразование иконок в Gliph'ы
Вот небольшой пример того, как можно загрузить иконку, содержащуюся в файле EXE, в Glyph у SpeedButton, и как очистить этот самый Glyph.
Огорчен, но комментарии в исходном коде на испанском языке.
|
unit Procs; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, StdCtrls, Buttons, ExtCtrls, ShellAPI; procedure LlenaBoton(boton: TSpeedButton; Programa: string); procedure LimpiaBoton(boton: TSpeedButton); var {Botones de programas} Pic: TPicture; Fname : String; TempFile: array[0..255] of Char; Icon : TIcon; implementation uses ttotro; procedure LlenaBoton(boton: TSpeedButton; Programa: string); var NumFiles, NameLength : integer; nIconsInFile : word; rBoton : TRect; oBitmap : TBitmap; oBitmap2: TBitmap; NombreBitmap: string; begin try screen.cursor := crHourglass; {Extrae el Icono} Icon := TIcon.Create; StrPCopy(TempFile, Programa); Icon.Handle := ExtractIcon(HInstance, TempFile, 0); {Crea una instancia de TPicture} Pic := TPicture.Create; {Asigna el icon.handle a la propiedad Pic.icon} Pic.Icon := Icon; {Configura el tamano del bitmap como el del icono y el del segundo bitmap con el tamano del boton} oBitmap := TBitMap.create; oBitmap2 := TBitMap.create; oBitmap2.Width := Icon.Width; oBitmap2.Height := Icon.Height; oBitmap.Width := boton.Width-4; oBitmap.Height := boton.Height-4; { Dibuja el icono en el bitmap } oBitmap2.Canvas.Draw( 0, 0, Pic.Graphic ); rBoton.left := 1; rBoton.Top := 1; rBoton.right:= boton.Width-6; rBoton.Bottom := boton.Height-6; oBitmap.Canvas.StretchDraw(rBoton, oBitmap2); Boton.Hint := Programa; NombreBitmap := Copy(programa, 1, Length(programa)-3)+'BMP'; {Salva el bitmap en un fichero} If Not FileExists(NombreBitmap) Then begin oBitmap.SaveToFile(ExtractFilePath(Application.ExeName)+ExtractFileName(NombreBitmap)); Boton.Glyph := oBitmap; end else {Carga el BMP en el boton} Boton.Glyph.LoadFromFile(ExtractFilePath(Application.ExeName)+ExtractFileName(NombreBitmap)); finally Icon.Free; oBitmap.Free; oBitmap2.Free; screen.cursor := crDefault; end; {main begin} end; {llenaboton} procedure LimpiaBoton(boton: TSpeedButton); var oBitmap : TBitmap; rBoton : TRect; begin try {Configuara el tamano del bitmap como el del icono y el del segundo bitmap con el tamano del boton} oBitmap := TBitMap.create; oBitmap.Width := boton.Width-4; oBitmap.Height := boton.Height-4; Boton.Glyph := oBitmap; finally oBitmap.Free; end; {main begin} end; {limpiaboton} end. |
[001805]
Преобразование RTF в HTML
Мне нужно перевести содержимое компонента RTF в HTML с помощью Delphi. Кто-нибудь знает как это сделать?
Приведу программу, которую я использую для преобразования содержимого RichEdit в SGML-код. Она не формирует полный HTML-аналог, но вы сами можете добавить необходимый RTF-код и его интерпретацию в HTML-тэги.
Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.
|
function rtf2sgml (text : string) : string; {Funktion för att konvertera en RTF-rad till SGML-text.} var temptext : string; start : integer; begin text := stringreplaceall (text,'&','##amp;'); text := stringreplaceall (text,'##amp','&'); text := stringreplaceall (text,'\'+chr(39)+'e5','å'); text := stringreplaceall (text,'\'+chr(39)+'c5','Å'); text := stringreplaceall (text,'\'+chr(39)+'e4','ä'); text := stringreplaceall (text,'\'+chr(39)+'c4','Ä'); text := stringreplaceall (text,'\'+chr(39)+'f6','ö'); text := stringreplaceall (text,'\'+chr(39)+'d6','Ö'); text := stringreplaceall (text,'\'+chr(39)+'e9','é'); text := stringreplaceall (text,'\'+chr(39)+'c9','É'); text := stringreplaceall (text,'\'+chr(39)+'e1','á'); text := stringreplaceall (text,'\'+chr(39)+'c1','Á'); text := stringreplaceall (text,'\'+chr(39)+'e0','à'); text := stringreplaceall (text,'\'+chr(39)+'c0','À'); text := stringreplaceall (text,'\'+chr(39)+'f2','ò'); text := stringreplaceall (text,'\'+chr(39)+'d2','Ò'); text := stringreplaceall (text,'\'+chr(39)+'fc','ü'); text := stringreplaceall (text,'\'+chr(39)+'dc','Ü'); text := stringreplaceall (text,'\'+chr(39)+'a3','£'); text := stringreplaceall (text,'\}','#]#'); text := stringreplaceall (text,'\{','#[#'); text := stringreplaceall (text,'{\rtf1\ansi\deff0\deftab720','');{Skall alltid tas bort} text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort} text := stringreplaceall (text,'{\f0\fnil MS Sans Serif;}','');{Skall alltid tas bort} text := stringreplaceall (text,'{\f1\fnil\fcharset2 Symbol;}','');{Skall alltid tas bort} text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort} text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort} {I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog därför bort det efter \fs16 och la istället en egen tvätt av \cf0.} //temptext := hamtastreng (text,'{\rtf1','\deflang'); //text := stringreplace (text,temptext,''); {Hämta och radera allt från start till deflang} text := stringreplaceall (text,'\cf0',''); temptext := hamtastreng (text,'\deflang','\pard');{Plocka från deflang till pard för att få } text := stringreplace (text,temptext,'');{oavsett vilken lang det är. Norska o svenska är olika} {Här skall vi plocka bort fs och flera olika siffror beroende på vilka alternativ vi godkänner.} //text := stringreplaceall (text,'\fs16','');{8 punkter} //text := stringreplaceall (text,'\fs20','');{10 punkter} {Nu städar vi istället bort alla tvåsiffriga fontsize.} while pos ('\fs',text) >0 do begin application.processmessages; start := pos ('\fs',text); Delete(text,start,5); end; text := stringreplaceall (text,'\pard\plain\f0 ','<P>'); text := stringreplaceall (text,'\par \plain\f0\b\ul ','</P><MELLIS>'); text := stringreplaceall (text,'\plain\f0\b\ul ','</P><MELLIS>'); text := stringreplaceall (text,'\plain\f0','</MELLIS>'); text := stringreplaceall (text,'\par }','</P>'); text := stringreplaceall (text,'\par ','</P><P>'); text := stringreplaceall (text,'#]#','}'); text := stringreplaceall (text,'#[#','{'); text := stringreplaceall (text,'\\','\'); result := text; end; |
|
//Нижеприведенный кусок кода вырезан из довольно большой программы, вызывающей вышеприведенную функцию. //Я знаю что мог бы использовать потоки вместо использования отдельного файла, но у меня не было времени для реализации этого utfilnamn := mditted.exepath+stringreplace(stringreplace(extractfilename(pathname),'.TTT',''),'.ttt','') + 'ut.RTF'; brodtext.lines.savetofile (utfilnamn); temptext := ''; assignfile(tempF,utfilnamn); reset (tempF); try while not eof(tempF) do begin readln (tempF,temptext2); temptext2 := stringreplaceall (temptext2,'\'+chr(39)+'b6',''); temptext2 := rtf2sgml (temptext2); if temptext2 <>'' then temptext := temptext+temptext2; application.processmessages; end; finally closefile (tempF); end; deletefile (utfilnamn); temptext := stringreplaceall (temptext,'</MELLIS> ','</MELLIS>'); temptext := stringreplaceall (temptext,'</P> ','</P>'); temptext := stringreplaceall (temptext,'</P>'+chr(0),'</P>'); temptext := stringreplaceall (temptext,'</MELLIS></P>','</MELLIS>'); temptext := stringreplaceall (temptext,'<P></P>',''); temptext := stringreplaceall (temptext,'</P><P></MELLIS>','</MELLIS><P>'); temptext := stringreplaceall (temptext,'</MELLIS>','<#MELLIS><P>'); temptext := stringreplaceall (temptext,'<#MELLIS>','</MELLIS>'); temptext := stringreplaceall (temptext,'<P><P>','<P>'); temptext := stringreplaceall (temptext,'<P> ','<P>'); temptext := stringreplaceall (temptext,'<P>-','<P>_'); temptext := stringreplaceall (temptext,'<P>_','<CITAT>_'); while pos('<CITAT>_',temptext)>0 do begin application.processmessages; temptext2 := hamtastreng (temptext,'<CITAT>_','</P>'); temptext := stringreplace (temptext,temptext2+'</P>',temptext2+'</CITAT>'); temptext := stringreplace (temptext,'<CITAT>_','<CITAT>-'); end; writeln (F,'<BRODTEXT>'+temptext+'</BRODTEXT>'); |
Преобразование String в Pchar
Тарасов Николай Валентинович советует:
|
function strtoPchar(s:string):Pchar; begin S := S+#0; result:=StrPCopy(@S[1], S) ; end; |
Алексей Варламов добавляет:
Преобразование String в Pchar:
| pch:=PChar(str); //Delphi 3+ |
обратно:
| str:=String(pch); |
[000884]
Преобразование в EBCDIC
Сам алгоритм преобразования очень прост...
|
Const a2e : array [0..255] of byte = (000,001,002,003,055,045,046,047,022,005,037,011,012,013,014,159, 016,017,018,019,182,181,050,038,024,025,063,039,028,029,030,031, 064,090,127,123,091,108,080,125,077,093,092,078,107,096,075,097, 240,241,242,243,244,245,246,247,248,249,122,094,076,126,110,111, 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, 215,216,217,226,227,228,229,230,231,232,233,173,224,189,095,109, 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, 151,152,153,162,163,164,165,166,167,168,169,192,106,208,161,007, 104,220,081,066,067,068,071,072,082,083,084,087,086,088,099,103, 113,156,158,203,204,205,219,221,224,236,252,176,177,178,062,180, 069,085,206,222,073,105,154,155,171,015,186,184,183,170,138,139, 060,061,098,079,100,101,102,032,033,034,112,035,114,115,116,190, 118,119,120,128,036,021,140,141,142,065,006,023,040,041,157,042, 043,044,009,010,172,074,174,175,027,048,049,250,026,051,052,053, 054,089,008,056,188,057,160,191,202,058,254,059,004,207,218,020, 225,143,070,117,253,235,238,237,144,239,179,251,185,234,187,255); Procedure StringA2E(var StringToConvert:String); Var Loop:Integer; begin For Loop := 1 to length(StringToConvert) do StringToConvert[Loop] := a2e[ord(StringToConvert[Loop])]; end; |
Это конвертирует любую строку... Можно доработать ее для того, чтобы она могла преобразовывать другие типы данных... Но если вам, к тому же, нужны дополнительные преобразования и обработка данных, то стоит задуматься о приобретении специализированного программного обеспечения...
- Matthew Augier [000866]
Преобразования типа Comp в тип Str
Были какие-то разговоры о том, что тип Comp является каким-то ущербным, недоделанным типом данных, что даже не существует подпрограмм, осуществляющих конвертацию Comp в string и обратно. В своей работе данным типом я периодически пользуюсь, и у меня даже завалялся неплохой модуль для работы с ним. Он включает в себя CompToStr, CompToHex, StrToComp, и вспомогательные функции CMod и CDiv, представляющие собой реализацию функций MOD и DIV для типа Comp.
Я обнаружил кое-что интересное в работе функций CMod и CDiv. Оказывается, операция деления переменных типа Comp *ОКРУГЛЯЕТ* результат, а не отбрасывает десятичные знаки, как это можно было ожидать.
Также я обнаружил некоторые странности на границах диапазона Comp. Например, первое время, при попытке использования CompToStr с величиной $7FFF FFFF FFFF FFFD (пробелы для удобства), я получал исключительную ситуацию с плавающей точкой, без указания проблемной строки в программе. Зато вторичная попытка исключения не вызывала. Потрясающе странно! Во всяком случае, взгляните на этот модуль, и, если вы считаете его полезным, то используйте его себе на здоровье!
Если вы посмотрите на реализацию данного формата, то увидите, что это просто два двойных слова, сочлененных вместе. Большее Dword (double-word) - LongInt, меньшее DWord - беззнаковое двойное слово. Я действительно не знаю, почему Delphi и Object Pascal рассматривают Comp как реальное число с плавающей точкой??
|
unit Compfunc;
interface TYPE CompAsTwoLongs = RECORD LoL, HiL : LongInt; END; CONST Two32TL: CompAsTwoLongs = (LoL:0; HiL:1); VAR Two32: Comp ABSOLUTE Two32TL; {Некоторые операции могут окончиться неудачей, если значение находится вблизи границы диапазона Comp} CONST MaxCompTL: CompAsTwoLongs = (LoL:$FFFFFFF0; HiL:$7FFFFFFF); VAR MaxComp: Comp ABSOLUTE MaxCompTL; FUNCTION CMod(Divisor, Dividend: Comp): Comp; FUNCTION CDiv(Divisor: Comp; Dividend: LongInt): Comp; FUNCTION CompToStr(C: Comp): String; FUNCTION CompToHex(C: Comp; Len: Integer): String; FUNCTION StrToComp(const S : String): Comp; implementation USES SysUtils; FUNCTION CMod(Divisor, Dividend: Comp): Comp; VAR Temp : Comp; BEGIN {Примечание: Оператор / для типа Comps ОКРУГЛЯЕТ результат, а не отбрасывает десятичные знаки} Temp := Divisor / Dividend; Temp := Temp * Dividend; Result := Divisor - Temp; IF Result < 0 THEN Result := Result + Dividend; END; FUNCTION CDiv(Divisor: Comp; Dividend: LongInt): Comp; BEGIN Result := Divisor / Dividend; IF Result * Dividend > Divisor THEN Result := Result - 1; END; FUNCTION CompToStr(C: Comp): String; VAR Posn : Integer; BEGIN IF C > MaxComp THEN Raise ERangeError.Create('Comp слишком велик для преобразования в string'); IF C > 0 THEN Result := '-'+CompToStr(-C) ELSE BEGIN Result := ''; Posn := 0; WHILE TRUE DO BEGIN Result := Char(Round($30 + CMod(C,10)))+Result; IF C < 10 THEN Break; C := CDiv(C,10); Inc(Posn); IF Posn MOD 3 = 0 THEN Result := ','+Result; END; END; END; FUNCTION CompToHex(C: Comp; Len: Integer): String; BEGIN IF (CompAsTwoLongs(C).HiL = 0) AND (Len <= 8) THEN Result := IntToHex(CompAsTwoLongs(C).LoL, Len) ELSE Result := IntToHex(CompAsTwoLongs(C).HiL, Len-8) + IntToHex(CompAsTwoLongs(C).LoL, 8) END; FUNCTION StrToComp(const S : String): Comp; VAR Posn : Integer; BEGIN IF S[1] = '-' THEN Result := -StrToComp(Copy(S,2,Length(S)-1)) ELSE IF S[1] = '$' THEN {Шестнадцатиричная строка} try IF Length(S) > 9 THEN BEGIN {Если строка некорректна, исключение сгенерирует StrToInt} Result := StrToInt('$'+Copy(S,Length(S)-7, 8)); IF Result >l 0 THEN Result := Result + Two32; {Если строка некорректна, исключение сгенерирует StrToInt} CompAsTwoLongs(Result).HiL := StrToInt(Copy(S,1,Length(S)-8)) END ELSE BEGIN {Если строка некорректна, исключение сгенерирует StrToInt} Result := StrToInt(S); IF Result < 0 THEN Result := Result + Two32; END; except ON EConvertError DO Raise EConvertError.Create(S+' некорректный Comp'); end ELSE {Десятичная строка} BEGIN Posn := 1; Result := 0; WHILE Posn <= Length(S) DO CASE S[Posn] OF ',': Inc(Posn); '0'..'9': BEGIN Result := Result * 10 + Ord(S[Posn])-$30; Inc(Posn); END; ELSE Raise EConvertError.Create(S+ ' некорректный Comp'); END; END; END; end. |
-Neil Rubenkind [000635]
Синтаксический анализ строки
Приведу модуль, где я собрал большое количество программ этого типа.
Имена функций и комментарии написаны на шведском языке, но тем не менее разобраться с тем, что делает код не так уж и сложно.
Например, для замены всех подстрок в тексте достаточно вызвать stringreplaceall с тремя параметрами - строкой, искомой подстрокой, заменяемой подстрокой и функция возвратит исправленную строку. Но будьте внимательны, заменяемая подстрока не должна быть составной частью искомой подстроки. В этом случае вы должны вызвать функцию дважды с различными параметрами (метод итерации), иначе вы получите бесконечный цикл.
Так, если у вас есть текст, содержащий слово Joe и вам необходимо заменить все вхождения этого слова на Joey, необходимо сделать две итерации, сначала:
text := stringreplaceall (text,'Joe','Joeey');
и затем
text := stringreplaceall (text,'Joeey','Joey');
|
unit sparfunc; interface uses sysutils,classes; function antaltecken (orgtext,soktext : string) : integer; function beginsWith (text,teststreng : string):boolean; function endsWith (text,teststreng : string):boolean; function hamtastreng (text,strt,slut : string):string; function hamtastrengmellan (text,strt,slut : string):string; function nastadelare (progtext : string):integer; function rtf2sgml (text : string) : string; Function sgml2win(text : String) : String; Function sgml2mac(text : String) : String; Function sgml2rtf(text : string) : String; function sistamening(text : string) : string; function stringnthfield (text,delim : string; vilken : integer) : string; function stringreplace (text,byt,mot : string) : string; function stringreplaceall (text,byt,mot : string) : string; function text2sgml (text : string) : string; procedure SurePath (pathen : string); procedure KopieraFil (infil,utfil : string); function LasInEnTextfil (filnamn : string) : string; implementation function LasInEnTextfil (filnamn : string) : string; var infil : textfile; temptext, filtext : string; begin filtext := ''; //Öppna angiven fil och läs in den try assignfile (infil,filnamn); //Koppla en textfilsvariabel till pathname reset (infil); //Öppna filen while not eof(infil) do begin //Så länge vi inte nått slutet readln (infil,temptext); //Läs in en rad filtext := filtext+temptext; //Lägg den till variabeln SGMLTEXT end; // while finally //slutligen closefile (infil); //Stäng filen end; //try result := filtext; end; procedure KopieraFil (infil,utfil : string); var InStream : TFileStream; OutStream : TFileStream; begin InStream := TFileStream.Create(infil,fmOpenRead); try OutStream := TFileStream.Create(utfil,fmOpenWrite or fmCreate); try OutStream.CopyFrom(InStream,0); finally OutStream.Free; end; finally InStream.Free; end; end; procedure SurePath (pathen : string); var temprad,del1 : string; antal : integer; begin antal := antaltecken (pathen,'\'); if antal<3 then createdir(pathen) else begin if pathen[length(pathen)] <> '\' then pathen := pathen+'\'; pathen := stringreplace(pathen,'\','/'); del1 := copy(pathen,1,pos('\',pathen)); pathen := stringreplace(pathen,del1,''); del1 := stringreplace(del1,'/','\'); createdir (del1); while pathen <> '' do begin temprad := copy(pathen,1,pos('\',pathen)); pathen := stringreplace(pathen,temprad,''); del1 := del1+ temprad; temprad := ''; createdir(del1); end; end; end; function antaltecken (orgtext,soktext : string) : integer; var i,traffar,soklengd : integer; begin traffar := 0; soklengd := length(soktext); for i := 1 to length(orgtext) do begin if soktext = copy(orgtext,i,soklengd) then traffar := traffar +1; end; result := traffar; end; function nastadelare (progtext : string):integer; var i,j : integer; begin i := pos('.',progtext); j := pos('!',progtext); if (j<i) and (j>0) then i := j; j := pos('!',progtext); if (j<i) and (j>0) then i := j; j := pos('?',progtext); if (j<i) and (j>0) then i := j; result := i; end; function stringnthfield (text,delim : string; vilken : integer) : string; var start,slut,i : integer; temptext : string; begin start := 0; if vilken >0 then begin temptext := text; if vilken = 1 then begin start := 1; slut := pos (delim,text); end else begin for i:= 1 to vilken -1 do begin start := pos(delim,temptext)+length(delim); temptext := copy(temptext,start,length(temptext)); end; slut := pos (delim,temptext); end; if start >0 then begin if slut = 0 then slut := length(text); result := copy (temptext,1,slut-1); end else result := text; end else result := text; end; function StringReplaceAll (text,byt,mot : string ) :string; {Funktion för att byta ut alla förekomster av en sträng mot en annan sträng in en sträng. Den konverterade strängen returneras. Om byt finns i mot måste vi gå via en temporär variant!!!} var plats : integer; begin While pos(byt,text) > 0 do begin plats := pos(byt,text); delete (text,plats,length(byt)); insert (mot,text,plats); end; result := text; end; function StringReplace (text,byt,mot : string ) :string; {Funktion för att byta ut den första förekomsten av en sträng mot en annan sträng in en sträng. Den konverterade strängen returneras.} var plats : integer; begin if pos(byt,text) > 0 then begin plats := pos(byt,text); delete (text,plats,length(byt)); insert (mot,text,plats); end; result := text; end; function hamtastreng (text,strt,slut : string):string; {Funktion för att hämta ut en delsträng ur en annan sträng. Om start och slut finns i text så returneras en sträng där start ingår i början och fram till tecknet före slut.} var stplats,slutplats : integer; resultat : string; begin resultat :=''; stplats := pos(strt,text); if stplats >0 then begin text := copy (text,stplats,length(text)); slutplats := pos(slut,text); if slutplats >0 then begin resultat := copy(text,1,slutplats-1); end; end; result := resultat; end; function hamtastrengmellan (text,strt,slut : string):string; {Funktion för att hämta ut en delsträng ur en annan sträng. Om start och slut finns i text så returneras en sträng där start ingår i början och fram till tecknet före slut.} var stplats,slutplats : integer; resultat : string; begin resultat :=''; stplats := pos(strt,text); if stplats >0 then begin text := copy (text,stplats+length(strt),length(text)); slutplats := pos(slut,text); if slutplats >0 then begin resultat := copy(text,1,slutplats-1); end; end; result := resultat; end; function endsWith (text,teststreng : string):boolean; {Kollar om en sträng slutar med en annan sträng. Returnerar true eller false.} var textlngd,testlngd : integer; kollstreng : string; begin testlngd := length(teststreng); textlngd := length (text); if textlngd > testlngd then begin kollstreng := copy (text,(textlngd+1)-testlngd,testlngd); if kollstreng = teststreng then result := true else result := false; end else result := false; end; function beginsWith (text,teststreng : string):boolean; {Funktion för att kolla om text börjar med teststreng. Returnerar true eller false.} var textlngd,testlngd : integer; kollstreng : string; begin testlngd := length(teststreng); textlngd := length (text); if textlngd >= testlngd then begin kollstreng := copy (text,1,testlngd); if kollstreng = teststreng then result := true else result := false; end else result := false; end; function sistamening(text : string) : string; //Funktion för att ta fram sista meningen i en sträng. Söker på !?. var i:integer; begin i :=length(text)-1; while (copy(text,i,1)<> '.') and (copy(text,i,1)<> '!') and (copy(text,i,1)<> '?') do begin dec(i); if i =1 then break end; if i>1 then result := copy(text,i,length(text)) else result := ''; end; Function text2sgml(text : String) : String; {Funktion som byter ut alla ovanliga tecken mot entiteter. Den färdiga texten returneras.} begin text := stringreplaceall (text,'&','##amp;'); text := stringreplaceall (text,'##amp','&'); text := stringreplaceall (text,'å','å'); text := stringreplaceall (text,'Å','Å'); text := stringreplaceall (text,'ä','ä'); text := stringreplaceall (text,'Ä','Ä'); text := stringreplaceall (text,'á','á'); text := stringreplaceall (text,'Á','Á'); text := stringreplaceall (text,'à','à'); text := stringreplaceall (text,'À','À'); text := stringreplaceall (text,'æ','æ'); text := stringreplaceall (text,'Æ','&Aelig;'); text := stringreplaceall (text,'Â','Â'); text := stringreplaceall (text,'â','â'); text := stringreplaceall (text,'ã','ã'); text := stringreplaceall (text,'Ã','Ã'); text := stringreplaceall (text,'ç','ç'); text := stringreplaceall (text,'Ç','Ç'); text := stringreplaceall (text,'é','é'); text := stringreplaceall (text,'É','É'); text := stringreplaceall (text,'ê','ê'); text := stringreplaceall (text,'Ê','Ê'); text := stringreplaceall (text,'ë','ë'); text := stringreplaceall (text,'Ë','Ë'); text := stringreplaceall (text,'è','è'); text := stringreplaceall (text,'È','È'); text := stringreplaceall (text,'î','î'); text := stringreplaceall (text,'Î','Î'); text := stringreplaceall (text,'í','í'); text := stringreplaceall (text,'Í','Í'); text := stringreplaceall (text,'ì','ì'); text := stringreplaceall (text,'Ì','Ì'); text := stringreplaceall (text,'ï','ï'); text := stringreplaceall (text,'Ï','Ï'); text := stringreplaceall (text,'ñ','ñ'); text := stringreplaceall (text,'Ñ','Ñ'); text := stringreplaceall (text,'ö','ö'); text := stringreplaceall (text,'Ö','Ö'); text := stringreplaceall (text,'ò','ò'); text := stringreplaceall (text,'Ò','Ò'); text := stringreplaceall (text,'ó','ó'); text := stringreplaceall (text,'Ó','Ó'); text := stringreplaceall (text,'ø','ø'); text := stringreplaceall (text,'Ø','Ø'); text := stringreplaceall (text,'Ô','Ô'); text := stringreplaceall (text,'ô','ô'); text := stringreplaceall (text,'õ','õ'); text := stringreplaceall (text,'Õ','Õ'); text := stringreplaceall (text,'ü','ü'); text := stringreplaceall (text,'Ü','Ü'); text := stringreplaceall (text,'ú','ú'); text := stringreplaceall (text,'Ú','Ú'); text := stringreplaceall (text,'Ù','Ù'); text := stringreplaceall (text,'ù','ù'); text := stringreplaceall (text,'û','û'); text := stringreplaceall (text,'Û','Û'); text := stringreplaceall (text,'ý','ý'); text := stringreplaceall (text,'Ý','Ý'); text := stringreplaceall (text,'ÿ','ÿ'); text := stringreplaceall (text,'|',' '); result := text; End; Function sgml2win(text : String) : String; {Funktion som ersätter alla entiteter mot deras tecken i windows. Den färdiga strängen returneras.} begin text := stringreplaceall (text,'á','á'); text := stringreplaceall (text,'Á','Á'); text := stringreplaceall (text,'æ','æ'); text := stringreplaceall (text,'&Aelig;','Æ'); text := stringreplaceall (text,'à','à'); text := stringreplaceall (text,'À','À'); text := stringreplaceall (text,'å','å'); text := stringreplaceall (text,'Å','Å'); text := stringreplaceall (text,'ä','ä'); text := stringreplaceall (text,'Ä','Ä'); text := stringreplaceall (text,'Â' ,'Â'); text := stringreplaceall (text,'â' ,'â'); text := stringreplaceall (text,'ã','ã'); text := stringreplaceall (text,'Ã','Ã'); text := stringreplaceall (text,'ç','ç'); text := stringreplaceall (text,'Ç','Ç'); text := stringreplaceall (text,'é','é'); text := stringreplaceall (text,'É','É'); text := stringreplaceall (text,'è','è'); text := stringreplaceall (text,'È','È'); text := stringreplaceall (text,'ê' ,'ê'); text := stringreplaceall (text,'Ê' ,'Ê'); text := stringreplaceall (text,'ë' ,'ë'); text := stringreplaceall (text,'Ë' ,'Ë'); text := stringreplaceall (text,'î' ,'î'); text := stringreplaceall (text,'Î' ,'Î'); text := stringreplaceall (text,'í','í'); text := stringreplaceall (text,'Í','Í'); text := stringreplaceall (text,'ì','ì'); text := stringreplaceall (text,'Ì','Ì'); text := stringreplaceall (text,'ï' ,'ï'); text := stringreplaceall (text,'Ï' ,'Ï'); text := stringreplaceall (text,'ñ','ñ'); text := stringreplaceall (text,'Ñ','Ñ'); text := stringreplaceall (text,'ò','ò'); text := stringreplaceall (text,'Ò','Ò'); text := stringreplaceall (text,'ó','ó'); text := stringreplaceall (text,'Ó','Ó'); text := stringreplaceall (text,'ö','ö'); text := stringreplaceall (text,'Ö','Ö'); text := stringreplaceall (text,'ø','ø'); text := stringreplaceall (text,'Ø','Ø'); text := stringreplaceall (text,'Ô' ,'Ô'); text := stringreplaceall (text,'ô' ,'ô'); text := stringreplaceall (text,'õ','õ'); text := stringreplaceall (text,'Õ','Õ'); text := stringreplaceall (text,'ü','ü'); text := stringreplaceall (text,'Ü','Ü'); text := stringreplaceall (text,'ú','ú'); text := stringreplaceall (text,'Ú','Ú'); text := stringreplaceall (text,'û' ,'û'); text := stringreplaceall (text,'Û' ,'Û'); text := stringreplaceall (text,'Ù','Ù'); text := stringreplaceall (text,'ù','ù'); text := stringreplaceall (text,'ý','ý'); text := stringreplaceall (text,'Ý','Ý'); text := stringreplaceall (text,'ÿ' ,'ÿ'); text := stringreplaceall (text,' ','|'); text := stringreplaceall (text,'&','&'); result := text; End; Function sgml2mac(text : String) : String; {Funktion som ersätter alla entiteter mot deras tecken i mac. Den färdiga strängen returneras.} begin text := stringreplaceall (text,'á',chr(135)); text := stringreplaceall (text,'Á',chr(231)); text := stringreplaceall (text,'æ',chr(190)); text := stringreplaceall (text,'&Aelig;',chr(174)); text := stringreplaceall (text,'à',chr(136)); text := stringreplaceall (text,'À',chr(203)); text := stringreplaceall (text,'å',chr(140)); text := stringreplaceall (text,'Å',chr(129)); text := stringreplaceall (text,'Ä',chr(128)); text := stringreplaceall (text,'ä',chr(138)); text := stringreplaceall (text,'Â' ,chr(229)); text := stringreplaceall (text,'â' ,chr(137)); text := stringreplaceall (text,'ã',chr(139)); text := stringreplaceall (text,'Ã',chr(204)); text := stringreplaceall (text,'ç',chr(141)); text := stringreplaceall (text,'Ç',chr(130)); text := stringreplaceall (text,'é',chr(142)); text := stringreplaceall (text,'É',chr(131)); text := stringreplaceall (text,'è',chr(143)); text := stringreplaceall (text,'È',chr(233)); text := stringreplaceall (text,'ê' ,chr(144)); text := stringreplaceall (text,'Ê' ,chr(230)); text := stringreplaceall (text,'ë' ,chr(145)); text := stringreplaceall (text,'Ë' ,chr(232)); text := stringreplaceall (text,'î' ,chr(148)); text := stringreplaceall (text,'Î' ,chr(235)); text := stringreplaceall (text,'í' ,chr(146)); text := stringreplaceall (text,'Í' ,chr(234)); text := stringreplaceall (text,'ì' ,chr(147)); text := stringreplaceall (text,'Ì' ,chr(237)); text := stringreplaceall (text,'ï' ,chr(149)); text := stringreplaceall (text,'Ï' ,chr(236)); text := stringreplaceall (text,'ñ',chr(150)); text := stringreplaceall (text,'Ñ',chr(132)); text := stringreplaceall (text,'ò',chr(152)); text := stringreplaceall (text,'Ò',chr(241)); text := stringreplaceall (text,'ó',chr(151)); text := stringreplaceall (text,'Ó',chr(238)); text := stringreplaceall (text,'Ô' ,chr(239)); text := stringreplaceall (text,'ô' ,chr(153)); text := stringreplaceall (text,'ø',chr(191)); text := stringreplaceall (text,'Ø',chr(175)); text := stringreplaceall (text,'õ',chr(155)); text := stringreplaceall (text,'Õ',chr(239)); text := stringreplaceall (text,'ö',chr(154)); text := stringreplaceall (text,'Ö',chr(133)); text := stringreplaceall (text,'ü',chr(159)); text := stringreplaceall (text,'Ü',chr(134)); text := stringreplaceall (text,'ú',chr(156)); text := stringreplaceall (text,'Ú',chr(242)); text := stringreplaceall (text,'û' ,chr(158)); text := stringreplaceall (text,'Û' ,chr(243)); text := stringreplaceall (text,'Ù',chr(244)); text := stringreplaceall (text,'ù',chr(157)); text := stringreplaceall (text,'ý','y'); text := stringreplaceall (text,'ÿ' ,chr(216)); text := stringreplaceall (text,'Ÿ' ,chr(217)); text := stringreplaceall (text,' ',' '); text := stringreplaceall (text,'&',chr(38)); result := text; End; Function sgml2rtf(text : string) : String; {Funktion för att byta ut sgml-entiteter mot de koder som gäller i RTF-textrutorna.} begin text := stringreplaceall (text,'}','#]#'); text := stringreplaceall (text,'{','#[#'); text := stringreplaceall (text,'\','HSALSKCAB'); text := stringreplaceall (text,'HSALSKCAB','\\'); text := stringreplaceall (text,'æ','\'+chr(39)+'c6'); text := stringreplaceall (text,'&Aelig;','\'+chr(39)+'e6'); text := stringreplaceall (text,'á','\'+chr(39)+'e1'); text := stringreplaceall (text,'Á','\'+chr(39)+'c1'); text := stringreplaceall (text,'à','\'+chr(39)+'e0'); text := stringreplaceall (text,'À','\'+chr(39)+'c0'); text := stringreplaceall (text,'å','\'+chr(39)+'e5'); text := stringreplaceall (text,'Å','\'+chr(39)+'c5'); text := stringreplaceall (text,'Â','\'+chr(39)+'c2'); text := stringreplaceall (text,'â','\'+chr(39)+'e2'); text := stringreplaceall (text,'ã','\'+chr(39)+'e3'); text := stringreplaceall (text,'Ã','\'+chr(39)+'c3'); text := stringreplaceall (text,'ä','\'+chr(39)+'e4'); text := stringreplaceall (text,'Ä','\'+chr(39)+'c4'); text := stringreplaceall (text,'ç','\'+chr(39)+'e7'); text := stringreplaceall (text,'Ç','\'+chr(39)+'c7'); text := stringreplaceall (text,'é','\'+chr(39)+'e9'); text := stringreplaceall (text,'É','\'+chr(39)+'c9'); text := stringreplaceall (text,'è','\'+chr(39)+'e8'); text := stringreplaceall (text,'È','\'+chr(39)+'c8'); text := stringreplaceall (text,'ê','\'+chr(39)+'ea'); text := stringreplaceall (text,'Ê','\'+chr(39)+'ca'); text := stringreplaceall (text,'ë','\'+chr(39)+'eb'); text := stringreplaceall (text,'Ë','\'+chr(39)+'cb'); text := stringreplaceall (text,'î','\'+chr(39)+'ee'); text := stringreplaceall (text,'Î','\'+chr(39)+'ce'); text := stringreplaceall (text,'í','\'+chr(39)+'ed'); text := stringreplaceall (text,'Í','\'+chr(39)+'cd'); text := stringreplaceall (text,'ì','\'+chr(39)+'ec'); text := stringreplaceall (text,'Ì','\'+chr(39)+'cc'); text := stringreplaceall (text,'ï' ,'\'+chr(39)+'ef'); text := stringreplaceall (text,'Ï' ,'\'+chr(39)+'cf'); text := stringreplaceall (text,'ñ','\'+chr(39)+'f1'); text := stringreplaceall (text,'Ñ','\'+chr(39)+'d1'); text := stringreplaceall (text,'ö','\'+chr(39)+'f6'); text := stringreplaceall (text,'Ö','\'+chr(39)+'d6'); text := stringreplaceall (text,'ó','\'+chr(39)+'f3'); text := stringreplaceall (text,'Ó','\'+chr(39)+'d3'); text := stringreplaceall (text,'ò','\'+chr(39)+'f2'); text := stringreplaceall (text,'Ò','\'+chr(39)+'d2'); text := stringreplaceall (text,'ø','\'+chr(39)+'f8'); text := stringreplaceall (text,'Ø','\'+chr(39)+'d8'); text := stringreplaceall (text,'Ô','\'+chr(39)+'d4'); text := stringreplaceall (text,'ô','\'+chr(39)+'f4'); text := stringreplaceall (text,'õ','\'+chr(39)+'f5'); text := stringreplaceall (text,'Õ','\'+chr(39)+'d5'); text := stringreplaceall (text,'ú','\'+chr(39)+'fa'); text := stringreplaceall (text,'Ú','\'+chr(39)+'da'); text := stringreplaceall (text,'û','\'+chr(39)+'fb'); text := stringreplaceall (text,'Û','\'+chr(39)+'db'); text := stringreplaceall (text,'Ù','\'+chr(39)+'d9'); text := stringreplaceall (text,'ù','\'+chr(39)+'f9'); text := stringreplaceall (text,'ü','\'+chr(39)+'fc'); text := stringreplaceall (text,'Ü','\'+chr(39)+'dc'); text := stringreplaceall (text,'ý','\'+chr(39)+'fd'); text := stringreplaceall (text,'Ý','\'+chr(39)+'dd'); text := stringreplaceall (text,'ÿ','\'+chr(39)+'ff'); text := stringreplaceall (text,'£','\'+chr(39)+'a3'); text := stringreplaceall (text,'#]#','\}'); text := stringreplaceall (text,'#[#','\{'); text := stringreplaceall (text,' ','|'); text := stringreplaceall (text,'&','&'); result := text; End; function rtf2sgml (text : string) : string; {Funktion för att konvertera en RTF-rad till SGML-text.} var temptext : string; start : integer; begin text := stringreplaceall (text,'&','##amp;'); text := stringreplaceall (text,'##amp','&'); text := stringreplaceall (text,'\'+chr(39)+'c6','æ'); text := stringreplaceall (text,'\'+chr(39)+'e6','&Aelig;'); text := stringreplaceall (text,'\'+chr(39)+'e5','å'); text := stringreplaceall (text,'\'+chr(39)+'c5','Å'); text := stringreplaceall (text,'\'+chr(39)+'e4','ä'); text := stringreplaceall (text,'\'+chr(39)+'c4','Ä'); text := stringreplaceall (text,'\'+chr(39)+'e1','á'); text := stringreplaceall (text,'\'+chr(39)+'c1','Á'); text := stringreplaceall (text,'\'+chr(39)+'e0','à'); text := stringreplaceall (text,'\'+chr(39)+'c0','À'); text := stringreplaceall (text,'\'+chr(39)+'c2','Â'); text := stringreplaceall (text,'\'+chr(39)+'e2','â'); text := stringreplaceall (text,'\'+chr(39)+'e3','ã'); text := stringreplaceall (text,'\'+chr(39)+'c3','Ã'); text := stringreplaceall (text,'\'+chr(39)+'e7','ç'); text := stringreplaceall (text,'\'+chr(39)+'c7','Ç'); text := stringreplaceall (text,'\'+chr(39)+'e9','é'); text := stringreplaceall (text,'\'+chr(39)+'c9','É'); text := stringreplaceall (text,'\'+chr(39)+'e8','è'); text := stringreplaceall (text,'\'+chr(39)+'c8','È'); text := stringreplaceall (text,'\'+chr(39)+'ea','ê'); text := stringreplaceall (text,'\'+chr(39)+'ca','Ê'); text := stringreplaceall (text,'\'+chr(39)+'eb','ë'); text := stringreplaceall (text,'\'+chr(39)+'cb','Ë'); text := stringreplaceall (text,'\'+chr(39)+'ee','î'); text := stringreplaceall (text,'\'+chr(39)+'ce','Î'); text := stringreplaceall (text,'\'+chr(39)+'ed','í'); text := stringreplaceall (text,'\'+chr(39)+'cd','Í'); text := stringreplaceall (text,'\'+chr(39)+'ec','ì'); text := stringreplaceall (text,'\'+chr(39)+'cc','Ì'); text := stringreplaceall (text,'\'+chr(39)+'ef','ï'); text := stringreplaceall (text,'\'+chr(39)+'cf','Ï'); text := stringreplaceall (text,'\'+chr(39)+'f1','ñ'); text := stringreplaceall (text,'\'+chr(39)+'d1','Ñ'); text := stringreplaceall (text,'\'+chr(39)+'f3','ó'); text := stringreplaceall (text,'\'+chr(39)+'d3','Ó'); text := stringreplaceall (text,'\'+chr(39)+'f2','ò'); text := stringreplaceall (text,'\'+chr(39)+'d2','Ò'); text := stringreplaceall (text,'\'+chr(39)+'d4','Ô'); text := stringreplaceall (text,'\'+chr(39)+'f4','ô'); text := stringreplaceall (text,'\'+chr(39)+'f5','õ'); text := stringreplaceall (text,'\'+chr(39)+'d5','Õ'); text := stringreplaceall (text,'\'+chr(39)+'f8','ø'); text := stringreplaceall (text,'\'+chr(39)+'d8','Ø'); text := stringreplaceall (text,'\'+chr(39)+'f6','ö'); text := stringreplaceall (text,'\'+chr(39)+'d6','Ö'); text := stringreplaceall (text,'\'+chr(39)+'fc','ü'); text := stringreplaceall (text,'\'+chr(39)+'dc','Ü'); text := stringreplaceall (text,'\'+chr(39)+'fa','ú'); text := stringreplaceall (text,'\'+chr(39)+'da','Ú'); text := stringreplaceall (text,'\'+chr(39)+'fb','û'); text := stringreplaceall (text,'\'+chr(39)+'db','Û'); text := stringreplaceall (text,'\'+chr(39)+'d9','Ù'); text := stringreplaceall (text,'\'+chr(39)+'f9','ù'); text := stringreplaceall (text,'\'+chr(39)+'fd','ý'); text := stringreplaceall (text,'\'+chr(39)+'dd','Ý'); text := stringreplaceall (text,'\'+chr(39)+'ff','ÿ'); text := stringreplaceall (text,'|',' '); text := stringreplaceall (text,'\'+chr(39)+'a3','£'); text := stringreplaceall (text,'\}','#]#'); text := stringreplaceall (text,'\{','#[#'); if (beginswith (text, '{\rtf1\')) or (beginswith (text, '{\colortbl\')) then begin result := ''; exit; end; //text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort} //temptext := hamtastreng (text,'{\rtf1','{\f0');{Skall alltid tas bort} //text := stringreplace (text,temptext,''); //temptext := hamtastreng (text,'{\f0','{\f1');{Skall alltid tas bort} //text := stringreplace (text,temptext,''); //temptext := hamtastreng (text,'{\f1','{\f2');{Skall alltid tas bort} //text := stringreplace (text,temptext,''); //text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort} //text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort} {I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog därför bort det efter \fs16 och la istället en egen tvätt av \cf0.} //temptext := hamtastreng (text,'{\rtf1','\deflang'); //text := stringreplace (text,temptext,''); {Hämta och radera allt från start till deflang} text := stringreplaceall (text,'\cf0',''); temptext := hamtastreng (text,'\deflang','\pard');{Plocka från deflang till pard för att få } text := stringreplace (text,temptext,'');{oavsett vilken lang det är. Norska o svenska är olika} text := stringreplaceall (text,'\ltrpar',''); text := stringreplaceall (text,'\ql',''); text := stringreplaceall (text,'\ltrch',''); {Här skall vi plocka bort fs och flera olika siffror beroende på vilka alternativ vi godkänner.} //text := stringreplaceall (text,'\fs16','');{8 punkter} //text := stringreplaceall (text,'\fs20','');{10 punkter} {Nu städar vi istället bort alla tvåsiffriga fontsize.} while pos ('\fs',text) >0 do begin //application.processmessages; start := pos ('\fs',text); Delete(text,start,5); end; while pos ('\f',text) >0 do begin //application.processmessages; start := pos ('\f',text); Delete(text,start,3); end; text := stringreplaceall (text,'\pard\li200-200{\*\pn\pnlvlblt\pnf1\pnindent200{\pntxtb\'+chr(39)+'b7}}\plain ','</P><UL>'); text := stringreplaceall (text,'{\pntext\'+chr(39)+'b7\tab}','<LI>'); text := stringreplaceall (text, '\par <LI>','<LI>'); text := stringreplaceall (text, '\par <UL>','<UL>'); text := stringreplaceall (text,'\pard\plain ','<P>'); text := stringreplaceall (text,'\par \plain\b\ul ','</P><MELLIS>'); text := stringreplaceall (text,'\plain\b\ul ','</P><MELLIS>'); text := stringreplaceall (text,'\plain','</MELLIS>'); text := stringreplaceall (text,'\par }','</P>'); if (pos ('\par \tab ',text)>0) or (pos ('<P>\tab ',text)>0) then begin text := stringreplaceall (text,'\par \tab ','<TR><TD>'); text := stringreplaceall (text,'<P>\tab ','<TR><TD>'); text := stringreplaceall (text,'\tab ','</TD><TD>'); end else begin text := stringreplaceall (text,'\tab ',''); end; text := stringreplaceall (text,'\par ','</P><P>'); text := stringreplaceall (text,'#]#','}'); text := stringreplaceall (text,'#[#','{'); text := stringreplaceall (text,'\\','\'); if pos('<TD>',text)>0 then text := text+'</TD></TR>'; if pos('<LI>',text)>0 then text := text+'</LI>'; result := text; end; end. |
Sscanf в Delphi?
Некоторое время назад одна любезная душа прислала мне этот модуль. Я нашел его весьма полезным, но применять его вам надлежит с некоторой долей осторожности, ибо тэг %s иногда приводит к исключительным ситуациям.
|
unit Scanf; interface uses SysUtils; type EFormatError = class(ExCeption); function Sscanf(const s: string; const fmt : string; const Pointers : array of Pointer) : Integer; implementation { Sscanf выполняет синтаксический разбор входной строки. Параметры... s - входная строка для разбора fmt - 'C' scanf-форматоподобная строка для управления разбором %d - преобразование в Long Integer %f - преобразование в Extended Float %s - преобразование в строку (ограничено пробелами) другой символ - приращение позиции s на "другой символ" пробел - ничего не делает Pointers - массив указателей на присваиваемые переменные результат - количество действительно присвоенных переменных Например, ... Sscanf('Name. Bill Time. 7:32.77 Age. 8', '. %s . %d:%f . %d', [@Name, @hrs, @min, @age]); возвратит ... Name = Bill hrs = 7 min = 32.77 age = 8 } function Sscanf(const s: string; const fmt : string; const Pointers : array of Pointer) : Integer; var i,j,n,m : integer; s1 : string; L : LongInt; X : Extended; function GetInt : Integer; begin s1 := ''; while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] in ['0'..'9', '+', '-']) and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function GetFloat : Integer; begin s1 := ''; while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E']) and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function GetString : Integer; begin s1 := ''; while (s[n] = ' ') and (Length(s) > n) do inc(n); while (s[n] <> ' ') and (Length(s) >= n) do begin s1 := s1+s[n]; inc(n); end; Result := Length(s1); end; function ScanStr(c : Char) : Boolean; begin while (s[n] <> c) and (Length(s) > n) do inc(n); inc(n); If (n <= Length(s)) then Result := True else Result := False; end; function GetFmt : Integer; begin Result := -1; while (TRUE) do begin while (fmt[m] = ' ') and (Length(fmt) > m) do inc(m); if (m >= Length(fmt)) then break; if (fmt[m] = '%') then begin inc(m); case fmt[m] of 'd': Result := vtInteger; 'f': Result := vtExtended; 's': Result := vtString; end; inc(m); break; end; if (ScanStr(fmt[m]) = False) then break; inc(m); end; end; begin n := 1; m := 1; Result := 0; for i := 0 to High(Pointers) do begin j := GetFmt; case j of vtInteger : begin if GetInt > 0 then begin L := StrToInt(s1); Move(L, Pointers[i]^, SizeOf(LongInt)); inc(Result); end else break; end; vtExtended : begin if GetFloat > 0 then begin X := StrToFloat(s1); Move(X, Pointers[i]^, SizeOf(Extended)); inc(Result); end else break; end; vtString : begin if GetString > 0 then begin Move(s1, Pointers[i]^, Length(s1)+1); inc(Result); end else break; end; else break; end; end; end; end. |
Unix-строки (чтение и запись Unix-файлов)
Данный модуль позволяет читать и записывать файлы формата Unix.
|
unit StreamFile; interface Uses SysUtils; Procedure AssignStreamFile (var F : Text ; Filename : String); implementation Const BufferSize = 128; Type TStreamBuffer = Array [1..High (Integer)] of Char; TStreamBufferPointer = ^TStreamBuffer; TStreamFileRecord = Record Case Integer Of 1: ( Filehandle : Integer; Buffer : TStreamBufferPointer; BufferOffset : Integer; ReadCount : Integer; ); 2: ( Dummy : Array [1 .. 32] Of Char ) End; Function StreamFileOpen (var F : TTextRec) : Integer; Var Status : Integer; Begin With TStreamFileRecord (F.UserData) Do Begin GetMem (Buffer, BufferSize); Case F.Mode Of fmInput: FileHandle := FileOpen (StrPas (F.Name), fmShareDenyNone); fmOutput: FileHandle := FileCreate (StrPas (F.Name)); fmInOut: Begin FileHandle := FileOpen (StrPas (F.Name), fmShareDenyNone Or fmOpenWrite or fmOpenRead); If FileHandle <> -1 Then status := FileSeek (FileHandle, 0, 2); { Перемещаемся в конец файла. } F.Mode := fmOutput; End; End; BufferOffset := 0; ReadCount := 0; F.BufEnd := 0; { В этом месте подразумеваем что мы достигли конца файла (eof). } If FileHandle = -1 Then Result := -1 Else Result := 0; End; End; Function StreamFileInOut (var F : TTextRec) : Integer; Procedure Read (var Data : TStreamFileRecord); Procedure CopyData; Begin While (F.BufEnd < Sizeof (F.Buffer) - 2) And (Data.BufferOffset <= Data.ReadCount) And (Data.Buffer [Data.BufferOffset] <> #10) Do Begin F.Buffer [F.BufEnd] := Data.Buffer^ [Data.BufferOffset]; Inc (Data.BufferOffset); Inc (F.BufEnd); End; If Data.Buffer [Data.BufferOffset] = #10 Then Begin F.Buffer [F.BufEnd] := #13; Inc (F.BufEnd); F.Buffer [F.BufEnd] := #10; Inc (F.BufEnd); Inc (Data.BufferOffset); End; End; Begin F.BufEnd := 0; F.BufPos := 0; F.Buffer := ''; Repeat Begin If (Data.ReadCount = 0) Or (Data.BufferOffset > Data.ReadCount) Then Begin Data.BufferOffset := 1; Data.ReadCount := FileRead (Data.FileHandle, Data.Buffer^, BufferSize); End; CopyData; End Until (Data.ReadCount = 0) Or (F.BufEnd >= Sizeof (F.Buffer) - 2); Result := 0; End; Procedure Write (var Data : TStreamFileRecord); Var Status : Integer; Destination : Integer; II : Integer; Begin With TStreamFileRecord (F.UserData) Do Begin Destination := 0; For II := 0 To F.BufPos - 1 Do Begin If F.Buffer [II] <> #13 Then Begin Inc (Destination); Buffer^[Destination] := F.Buffer [II]; End; End; Status := FileWrite (FileHandle, Buffer^, Destination); F.BufPos := 0; Result := 0; End; End; Begin Case F.Mode Of fmInput: Read (TStreamFileRecord (F.UserData)); fmOutput: Write (TStreamFileRecord (F.UserData)); End; End; Function StreamFileFlush (var F : TTextRec) : Integer; Begin Result := 0; End; Function StreamFileClose (var F : TTextRec) : Integer; Begin With TStreamFileRecord (F.UserData) Do Begin FreeMem (Buffer); FileClose (FileHandle); End; Result := 0; End; Procedure AssignStreamFile (var F : Text ; Filename : String); Begin With TTextRec (F) Do Begin Mode := fmClosed; BufPtr := @Buffer; BufSize := Sizeof (Buffer); OpenFunc := @StreamFileOpen; InOutFunc := @StreamFileInOut; FlushFunc := @StreamFileFlush; CloseFunc := @StreamFileClose; StrPLCopy (Name, FileName, Sizeof(Name) - 1); End; End; end. |
А какой у меня процессор?
|
{ Ниже приведен код модуля Delphi, позволяющий определить тип CPU. Код является модифицированным кодом Intel. Использование его очевидно. Если для вас это утверждение спорно, пошлите мне ваш электронный адрес, и я вышлю вам демонстрационный пример. Поскольку Delphi ассемблер 16-битный, код смотрится несколько странным. Чтобы видеть 32-битные инструкции, попробуйте воспользоваться 32-битным дизассемблером (или прочтите комментарии). } unit CpuId; { Источником данного кода послужил код Intel, который был модифицирован для Delphi inline-ассемблера. Посколько Intel сделал свой код доступным, я также придаю ему статус свободнораспространяемого. |
Успехов!
Ray Lischner
Tempest Software
6/18/95
}
interface
type
{ Все типы известны. В случае создания новых, задайте им пригодные имена, и соответственно расширьте функцию CpuTypeString.
}
TCpuType = (cpu8086, cpu80286, cpu386, cpu486, cpuPentium);
{ Возвращает тип текущего CPU }
function CpuType: TCpuType;
{ Возвращаем тип как короткую строку }
function CpuTypeString: String;
implementation
uses SysUtils;
function CpuType: TCpuType; assembler;
asm
push DS
{ Во-первых, проверяем наличие 8086 CPU }
{ Биты 12-15 в регистре FLAGS всегда выставлены в }
{ 8086 процессоре. }
pushf { сохраняем EFLAGS }
pop bx { сохраняем EFLAGS в BX }
mov ax,0fffh { сбрасываем биты 12-15 }
and ax,bx { в EFLAGS }
push ax { сохраняем в стеке значение EFLAGS }
popf { замещаем текущее значение EFLAGS }
pushf { устанавливаем новый EFLAGS }
pop ax { сохраняем новый EFLAGS в AX }
and ax,0f000h { если биты 12-15 выставлены, то CPU }
cmp ax,0f000h { 8086/8088 }
mov ax, cpu8086 { вывешиваем флаг 8086/8088 }
je @@End_CpuType
{ Проверка 80286 CPU }
{ Биты 12-15 регистра FLAGS всегда очищены в случае }
{ 80286 процессора. }
or bx,0f000h { пробуем установить биты 12-15 }
push bx
popf
pushf
pop ax
and ax,0f000h { если биты 12-15 сброшены, CPU=80286 }
mov ax, cpu80286 { включаем флаг 80286 }
jz @@End_CpuType
{ Для определения процессоров марки 386 и выше, необходимо использовать 32-битные инструкции, но 16-битный ассемблер Delphi не признает 32-битные коды операций и операнды. Взамен этого используется префикс размера операнда 66H, который позволяет преобразовать каждую инструкцию в ее 32-битный эквивалент. Для непосредственных 32-битных операндов вам нужно будет также хранить первое слово операнда сразу после следующей за ним инструкции. 32-битная инструкция показана в комментариях после инструкции 66H. }
{ Проверяем на i386 CPU }
{ Бит AC и бит #18 - новые биты, введенные в регистр EFLAGS }
{ в i486 DX CPU для компенсационного выравнивания. }
{ Этот бит не может быть выставлен в i386 CPU. }
db 66h { pushfd }
pushf
db 66h { pop eax }
pop ax { получаем оригинальный EFLAGS }
db 66h { mov ecx, eax }
mov cx,ax { сохраняем оригинальный EFLAGS }
db 66h { xor eax,40000h }
xor ax,0h { перебрасываем бит AC в EFLAGS }
dw 0004h
db 66h { push eax }
push ax { сохраняем для EFLAGS }
db 66h { popfd }
popf { копируем в EFLAGS }
db 66h { pushfd }
pushf { выталкиваем EFLAGS }
db 66h { pop eax }
pop ax { получаем новое значение EFLAGS }
db 66h { xor eax,ecx }
xor ax,cx { невозможно переключить бит AC, CPU=Intel386 }
mov ax, cpu386 { включаем 386 флаг }
je @@End_CpuType
{ Производим проверку i486 DX CPU / i487 SX MCP и i486 SX CPU }
{ Проверяем способность устанавливать/сбрасывать флаг ID (бит 21) в EFLAGS, }
{ который указывает присутствие процессора }
{ с помощью использования инструкции CPUID. }
db 66h { pushfd }
pushf { выталкиваем оригинальный EFLAGS }
db 66h { pop eax }
pop ax { получаем оригинальный EFLAGS в eax }
db 66h { mov ecx, eax }
mov cx,ax { сохраняем оригинальный EFLAGS в ecx }
db 66h { xor eax,200000h }
xor ax,0h { перебрасываем бит ID в EFLAGS }
dw 0020h
db 66h { push eax }
push ax { сохраняем для EFLAGS }
db 66h { popfd }
popf { копируем в EFLAGS }
db 66h { pushfd }
pushf { выталкиваем EFLAGS }
db 66h { pop eax }
pop ax { получаем новое значение EFLAGS }
db 66h { xor eax, ecx }
xor ax, cx
mov ax, cpu486 { вывешиваем i486 флаг }
je @@End_CpuType { если бит ID не может быть изменен, CPU=486
}
{ инструкция CPUID без функционального назначения }
{ Выполняем инструкцию CPUID для определения поставщика, }
{ семейства, модели и версии. Инструкция CPUID для этих }
{ целей может быть использована, начиная с версии B0 }
{ процессора P5. }
db 66h { mov eax, 1 }
mov ax, 1 { устанавливаем для инструкции CPUID }
dw 0
db 66h { cpuid }
db 0Fh { код операции Hardcoded для инструкции CPUID }
db 0a2h
db 66h { and eax, 0F00H }
and ax, 0F00H { все маскируем }
dw 0
db 66h { shr eax, 8 }
shr ax, 8 { сдвигаем тип cpu вплоть до нижнего байта }
sub ax, 1 { вычитаем 1 для отображения на TCpuType }
@@End_CpuType:
pop ds
end;
function CpuTypeString: String;
var
kind: TCpuType;
begin
kind := CpuType;
case kind of
cpu8086:
Result := '8086';
cpu80286:
Result := '80286';
cpu386:
Result := '386';
cpu486:
Result := '486';
cpuPentium:
Result := 'Pentium';
else
{ Пытаемся добавить "гибкости" для будущих версий процессоров, например, для P6. }
Result := Format('P%d', [Ord(kind)]);
end;
end;
end.
[001953]
CPU Speed routine
Пришло мне письмо от Alex Novikov, где был вложен только код. К сожалению, авторство кода мне установить не удалось, хотя сам код потрясающий в своей простоте!
|
// // Determinate CPU Freq // // function GetCPUSpeed: Double; const DelayTime = 500; var TimerHi : DWORD; TimerLo : DWORD; PriorityClass : Integer; Priority : Integer; begin PriorityClass := GetPriorityClass(GetCurrentProcess); Priority := GetThreadPriority(GetCurrentThread); SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS); SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL); Sleep(10); asm DW 310Fh // rdtsc MOV TimerLo, EAX MOV TimerHi, EDX end; Sleep(DelayTime); asm DW 310Fh // rdtsc SUB EAX, TimerLo SBB EDX, TimerHi MOV TimerLo, EAX MOV TimerHi, EDX end; SetThreadPriority(GetCurrentThread, Priority); SetPriorityClass(GetCurrentProcess, PriorityClass); Result := TimerLo / (1000.0 * DelayTime); end; // Usage ... LabelCPUSpeed.Caption := Format('CPU speed: %f MHz', [GetCPUSpeed]); |
Как получить информацию о загрузке процессора?
Из советов Nomadic'a:
Читать из реестра HKEY_DYN_DATA\PerfStats\StatData соответствующий ключ Kernel \CPUUsage. [001683]
Получение информации о процессоре
Пришло мне письмо от Igor Popov, где он пишет:
Если Вам необходимо не только "вычислить" частоту процессора, а и узнать о процессоре как можно больше, пожалуйста, пользуйтесь следующим модулем:
|
unit ExpandCPUInfo; interface type TCPUInfo = packed record IDString : array [0..11] of Char; Stepping : Integer; Model : Integer; Family : Integer; FPU, VirtualModeExtensions, DebuggingExtensions, PageSizeExtensions, TimeStampCounter, K86ModelSpecificRegisters, MachineCheckException, CMPXCHG8B, APIC, MemoryTypeRangeRegisters, GlobalPagingExtension, ConditionalMoveInstruction, MMX : Boolean; SYSCALLandSYSRET, FPConditionalMoveInstruction, AMD3DNow : Boolean; CPUName : String; end; {информация об идентификации процессора} function ExistCPUID:Boolean; function CPUIDInfo(out info: TCPUInfo):Boolean; {инф-я о технологии процессора} function ExistMMX:Boolean; function Exist3DNow:Boolean; function ExistKNI:Boolean; {------------------------} procedure EMMS; procedure FEMMS; procedure PREFETCH(p: Pointer); register; implementation function ExistCPUID : Boolean; asm pushfd pop eax mov ebx, eax xor eax, 00200000h push eax popfd pushfd pop ecx mov eax,0 cmp ecx, ebx jz @NO_CPUID inc eax @NO_CPUID: end; function CPUIDInfo(out info: TCPUIDInfo):Boolean; function ExistExtendedCPUIDFunctions:Boolean; asm mov eax,080000000h db $0F,$A2 end; var name : array [0..47] of Char; p : Pointer; begin if ExistCPUID then asm jmp @Start @BitLoop: mov al,dl and al,1 mov [edi],al shr edx,1 inc edi loop @BitLoop ret @Start: mov edi,info mov eax,0 db $0F,$A2 mov [edi],ebx mov [edi+4],edx mov [edi+8],ecx mov eax,1 db $0F,$A2 mov ebx,eax and eax,0fh; mov [edi+12],eax; shr ebx,4 mov eax,ebx and eax,0fh mov [edi+12+4],eax shr ebx,4 mov eax,ebx and eax,0fh mov [edi+12+8],eax add edi,24 mov ecx,6 call @BitLoop shr edx,1 mov ecx,3 call @BitLoop shr edx,2 mov ecx,2 call @BitLoop shr edx,1 mov ecx,1 call @BitLoop shr edx,7 mov ecx,1 call @BitLoop mov p,edi end; if (info.IDString = 'AuthenticAMD') and ExistExtendedCPUIDFunctions then begin asm mov edi,p mov eax,080000001h db $0F,$A2 mov eax,edx shr eax,11 and al,1 mov [edi],al mov eax,edx shr eax,16 and al,1 mov [edi+1],al mov eax,edx shr eax,31 and al,1 mov [edi+2],al lea edi,name mov eax,0 mov [edi],eax mov eax,080000000h db $0F,$A2 cmp eax,080000004h jl @NoString mov eax,080000002h db $0F,$A2 mov [edi],eax mov [edi+4],ebx mov [edi+8],ecx mov [edi+12],edx add edi,16 mov eax,080000003h db $0F,$A2 mov [edi],eax mov [edi+4],ebx mov [edi+8],ecx mov [edi+12],edx add edi,16 mov eax,080000004h db $0F,$A2 mov [edi],eax mov [edi+4],ebx mov [edi+8],ecx mov [edi+12],edx @NoString: end; info.CPUName:=name; end else with info do begin SYSCALLandSYSRET:=False; FPConditionalMoveInstruction:=False; AMD3DNow:=False; CPUName:=''; end; Result:=ExistCPUID; end; function ExistMMX:Boolean; var info : TCPUIDInfo; begin if CPUIDInfo(info) then Result:=info.MMX else Result:=False; end; function Exist3DNow:Boolean; var info : TCPUIDInfo; begin if CPUIDInfo(info) then Result:=info.AMD3DNow else Result:=False; end; function ExistKNI:Boolean; begin Result:=False; end; procedure EMMS; asm db $0F,$77 end; procedure FEMMS; asm db $0F,$03 end; procedure PREFETCH(p: Pointer); register; asm // PREFETCH byte ptr [eax] end; end. |
Работа с портами микропроцессора
Пришло мне письмо от Pavlo Zolotarenki, где он пишет:
Модуль для работы с портами микропроцессора с сохранением синтаксиса.
Работает под Win9x.
НЕ работает под WinNT.
|
//Copyright(c) 1998 Zolotarenko P.V pvz@mail.univ.kiev.ua unit Ports; interface Type TPort=class private procedure Set_(index_:word;value:byte);register; function Get_(index_:word):byte;register; public property Element[index_ :word]:byte read Get_ write Set_ ;default; end; TPortW=class private procedure Set_(index_:word;value:Word);register; function Get_(index_:word):word;register; public property Element[index_ :word]:word read Get_ write Set_ ;default; end; Var Port :TPort; PortW :TportW; implementation procedure TPort.Set_(index_:word;value:byte); begin asm mov dx,index_ mov al,value out dx,al end; end; function TPort.Get_(index_:word):byte; begin asm mov dx,index_ in al,dx mov @Result,al end; end; procedure TPortW.Set_(index_:word;value:word); begin asm mov dx,index_ mov ax,value out dx,ax end; end; function TPortW.Get_(index_:word):word; begin asm mov dx,index_ in ax,dx mov @Result,ax end; end; initialization Port:=TPort.Create; PortW:=TPortW.Create; finalization Port.free; PortW.free; end. |
Советы по Delphi
Декларация события OnPassword
Мне необходимо написать процедуру для OnPassword с использованием TPasswordEvent. Но я никак не могу его прикрутить к объекту!
Объявление TPasswordEvent в исходном коде VCL неверно (исправлено в Delphi 2.0). Оно должно включать в себя ключевые слова "of object", как и все остальное объявления данного типа.
Есть два пути решения проблемы:
A) Изменить исходный код VCL
B) Создать не-стандартный обработчик события, работающий с неправильно декларированным.
Решение A - мой выбор, но для этого необходимо, чтобы вы имели копию исходного кода VCL. (Не пытайтесь пересобрать библиотеку VCL; просто измените файл и добавьте путь к файлу DB.PAS file в пути вашего проекта.)
Решение B немного более прагматичное и не требует изменения исходного кода VCL. Создайте следующую функцию:
| procedure PasswordProc(Sender: TObject; var Continue: Boolean); far; begin Session.AddPassword('Harrison'); Continue := True; end; |
Затем измените обработчик события OnCreate...
| procedure TForm1.FormCreate(Sender: TObject); begin Session.OnPassword := PasswordProc; Table1.Active := True; end; |
Важно чтобы вы добавляли ключевое слово "far" в конец объявления данной функции. Если этого не сделать, вам понадобиться добавлять объявление функций в секцию модуля Interface, чтобы заставить Delphi скомпилировать их как "far"-процедуры (которые вызываются из другого модуля).
Если вы решаете воспользоваться методом A, то единственное отличие будет заключаться в том, что вам понадобиться добавить объявление процедуры к вашему классу формы, и в секции Implementation ваша процедура должна выглядеть примерно так:
| procedure TForm1.PasswordProc(Sender: TObject; var Continue: Boolean); begin Session.AddPassword('Harrison'); Continue := True; end; |
Поскольку эта версия является функцией-членом, у нее существует преимущество при доступе к компонентам и private- или protected-членам вашей формы (TForm-производного класса).
- Tim Gooch [000797]
