تابع Windows String To Dos String
function WinToDosStr(WinStr:string):string;
var Nflag:boolean;
Ch:Char;
T,N,M,I,J,DosI:integer;
TmpStr,Str1,Str2:String;
DosSt:String;
begin
DosSt:=''; WinStr:=WinStr+' '; M:=length(WinStr);
for I:=1 to M do
DosSt:=DosSt + #32;
DosI:=M; Str1:='';
for I:=1 To M do
begin
Nflag:=False;
case WinStr[i] Of
' ' :Begin
Ch:=#32;
end;
'.','0' .. '9'
: begin
Ch:=chr(ord(WinStr[i])+80);
if (WinStr[i])='.' then
ch:=#140;
str1:=str1+ch;
Nflag:=true;
ch:=#0;
end;
'a' .. 'z',
'A' .. 'Z'
: begin
Ch:=WinStr[i];
str1:=str1+ch;
Nflag:=true;
ch:=#0;
end;
'آ' :begin
ch:=#141;
end;
'ئ' :Begin
Ch:=#142;
end;
'ء' :Begin
Ch:=#143;
end;
'ا' :begin
Ch:=#145;
if((WinStr[i-1]=' ')or
(WinStr[i-1]=#157)or
(WinStr[i-1]='ا')or
(WinStr[i-1]='و')or
(WinStr[i-1]='د')or
(WinStr[i-1]='ذ')or
(WinStr[i-1]='ر')or
(WinStr[i-1]='ز')or
(WinStr[i-1]='ژ')or
(i=1 )
)
then
ch:=#144;
end;
'ب' : begin
Ch:=#147;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
Ch:=#146;
end;
'پ' : begin
Ch:=#149;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
Ch:=#148;
end;
'ت' :begin
Ch:=#151;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
Ch:=#150;
end;
'ث' :begin
Ch:=#153;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#152
end;
'ج' :begin
Ch:=#155;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#154
end;
'چ' :begin
Ch:=#157;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#156;
end;
'ح' :begin
Ch:=#159;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#158;
end;
'خ' :begin
Ch:=#161;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#160;
end;
'د' :begin
Ch:=#162;
end;
'ذ' :begin
Ch:=#163;
end;
'ر' :begin
Ch:=#164;
end;
'ز' :begin
Ch:=#165;
end;
'ژ' :begin
Ch:=#166;
end;
'س' :begin
Ch:=#168;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
Ch:=#167;
end;
'ش' :begin
Ch:=#170;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#169;
end;
'ص' :begin
Ch:=#172;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#171;
end;
'ض' :begin
Ch:=#174;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#173;
end;
'ط' :begin
ch:=#175 ;
end;
'ظ' :begin
ch:=#224
end;
'ع' :begin
Ch:=#227;
if((WinStr[i-1]=' ')or
(WinStr[i-1]=#157)or
(WinStr[i-1]='ا')or
(WinStr[i-1]='و')or
(WinStr[i-1]='د')or
(WinStr[i-1]='ذ')or
(WinStr[i-1]='ر')or
(WinStr[i-1]='ز')or
(WinStr[i-1]='ژ')or
(i=1) )
then
ch:=#228;
if ((WinStr[i+1]=' ') or (i=M)) then
if (ch=#228) then
ch:=#225
else
ch:=#226;
end;
'غ' :begin
Ch:=#231;
if((WinStr[i-1]=' ')or
(WinStr[i-1]=#157)or
(WinStr[i-1]='ا')or
(WinStr[i-1]='و')or
(WinStr[i-1]='د')or
(WinStr[i-1]='ذ')or
(WinStr[i-1]='ر')or
(WinStr[i-1]='ز')or
(WinStr[i-1]='ژ')or
(i=1) )
then
ch:=#232;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
if (ch=#232) then
ch:=#229
else
ch:=#230;
end;
'ف' :begin
Ch:=#234;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#233;
end;
'ق' :begin
Ch:=#236;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#235;
end;
'ك' :begin
Ch:=#238;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#237;
end;
'گ' :begin
Ch:=#240;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#239 ;
end;
'ل' :begin
Ch:=#243;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#241;
end;
'م' :begin
Ch:=#245;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ') or (WinStr[i+1]='آ')) then
ch:=#244;
end;
'ن' :begin
Ch:=#247;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#246;
end;
'و' :begin
ch:=#248 ;
end;
'ه' :begin
Ch:=#250;
if((WinStr[i-1]=' ')or(WinStr[i-1]=#157)or(WinStr[i-1]='ا')or(WinStr[i-1]='و')or
(WinStr[i-1]='د')or(WinStr[i-1]='ذ')or(WinStr[i-1]='ر')or(WinStr[i-1]='ز')or
(WinStr[i-1]='ژ')or(i=1))
then
ch:=#251;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#249;
end;
'ي' :begin
Ch:=#254;
if ((WinStr[i+1]=#157) or (WinStr[i+1]=' ')) then
ch:=#252;
if (ord(WinStr[i])=236)then
Ch:=#254;
end;
'ـ' :begin
ch:=#139 ;
end;
else
ch:=WinStr[i];
end;
if (Nflag=false) and(ch<>#0) and (DosI>0 )then
begin
N:=length(str1);
for j:=N downto 1 do
if (WinStr[i]<>#157) then
begin
DosSt[DosI]:=str1[j];
Dec(DosI);
end;
if (WinStr[i]<>#157) then
begin
DosSt[DosI]:=Ch; Dec(DosI);
end;
str1:='';
end;
end;
if (Nflag=True) and(ch=#0) and (DosI>0 )then
begin
N:=length(str1);
for j:=N downto 1 do
begin
DosSt[DosI]:=str1[j];
Dec(DosI);
end;
end;
WinToDosStr:=copy(DosSt,2,length(DosSt));
end;
پاسخ با نقل قول