Related
In a 32-bit VCL Application in Windows 10 in Delphi 11 Alexandria, I am trying to get the window handle of a running main task from the task's module path:
type
TFindWindowRec = record
ModuleToFind: string;
FoundHWnd: HWND;
end;
function EnumWindowsCallBack(aHandle: HWND; var FindWindowRec: TFindWindowRec): BOOL; stdcall;
const
C_FileNameLength = 256;
var
WinFileName: string;
PID, hProcess: DWORD;
Len: Byte;
begin
Result := True;
SetLength(WinFileName, C_FileNameLength);
GetWindowThreadProcessId(aHandle, PID);
hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, PID);
Len := GetModuleFileNameEx(hProcess, 0, PChar(WinFileName), C_FileNameLength);
if Len > 0 then
begin
SetLength(WinFileName, Len);
if SameText(WinFileName, FindWindowRec.ModuleToFind) then
begin
Result := False;
FindWindowRec.FoundHWnd := aHandle;
end;
end;
end;
var
FindWindowRec: TFindWindowRec;
function TformMain.GetmainWindowHandleFRomProcessPath(aProcessPath: string): HWND;
begin
Result := 0;
CodeSite.Send('TformMain.GetmainWindowHandleFRomProcessPath: aProcessPath', aProcessPath);
FindWindowRec.ModuleToFind := aProcessPath;
FindWindowRec.FoundHWnd := 0;
EnumWindows(#EnumWindowsCallback, Integer(#FindWindowRec));
if FindWindowRec.FoundHWnd <> 0 then
begin
Result := FindWindowRec.FoundHWnd;
CodeSite.Send('TformMain.GetmainWindowHandleFRomProcessPath: Result', Result);
end;
end;
When I do this with:
GetmainWindowHandleFRomProcessPath('c:\windows\system32\notepad.exe');
... then I get the correct window handle.
When I do this with:
GetmainWindowHandleFRomProcessPath('C:\Program Files (x86)\Embarcadero\Studio\22.0\bin\bds.exe');
... then I get a WRONG (non-existing) window handle!
Why is this happening? How do I get the correct window handle?
The discussion with Remy and Andreas lead me to this successful working answer:
type
TFindWindowRec = record
ModuleToFind: string;
FoundHWnd: HWND;
end;
// The `RzShellUtils` unit is from Ray Konopka's Signature Library available from GetIt:
function PathsAreSamePIDL(const Path1, Path2: string): Boolean;
begin
var AIL1: PItemIdList;
var AIL2: PItemIdList;
RzShellUtils.ShellGetIdListFromPath(Path1, AIL1);
RzShellUtils.ShellGetIdListFromPath(Path2, AIL2);
var CompResult:= RzShellUtils.CompareAbsIdLists(AIL1, AIL2);
Result := CompResult = 0;
end;
function EnumWindowsCallBack(aHandle: HWND; var FindWindowRec: TFindWindowRec): BOOL; stdcall;
const
C_FileNameLength = MAX_PATH;
PROCESS_QUERY_LIMITED_INFORMATION = $1000;
var
WinFileName: string;
PID, hProcess: DWORD;
Len: Byte;
begin
Result := True;
SetLength(WinFileName, C_FileNameLength);
GetWindowThreadProcessId(aHandle, PID);
hProcess := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, False, PID);
Len := GetModuleFileNameEx(hProcess, 0, PChar(WinFileName), C_FileNameLength);
CloseHandle(hProcess);
if Len > 0 then
begin
SetLength(WinFileName, Len);
//if SameText(WinFileName, FindWindowRec.ModuleToFind) then
if PathsAreSamePIDL(WinFileName, FindWindowRec.ModuleToFind) then
begin
var IsVisible := IsWindowVisible(aHandle);
if not IsVisible then EXIT;
var IsOwned := GetWindow(aHandle, GW_OWNER) <> 0;
if IsOwned then EXIT;
var IsAppWindow := GetWindowLongPtr(aHandle, GWL_EXSTYLE) and WS_EX_APPWINDOW <> 0;
if not IsAppWindow then EXIT;
Result := False;
FindWindowRec.FoundHWnd := aHandle;
end;
end;
end;
function TformMain.GetMainWindowHandleFromProcessPath(aProcessPath: string): HWND;
var
FindWindowRec: TFindWindowRec;
begin
Result := 0;
FindWindowRec.ModuleToFind := aProcessPath;
FindWindowRec.FoundHWnd := 0;
EnumWindows(#EnumWindowsCallback, LPARAM(#FindWindowRec));
if FindWindowRec.FoundHWnd <> 0 then
begin
Result := FindWindowRec.FoundHWnd;
end;
end;
I don't understand why the person who moved the discussion to another page deleted the latest comments. Was there anything forbidden in those deleted comments?
Again: Thank you to Remy and Andreas!
in two different project i need to use crc16 checksum.one in windows and other in android.i used a code for windows and it worked prefect.
showmessage( bin2crc16(HexToBin('1234')) ); //---> 0EC9
here is used function for winsows
function Pow(i, k: Integer): Integer;
var
j, Count: Integer;
begin
if k>0 then j:=2
else j:=1;
for Count:=1 to k-1 do
j:=j*2;
Result:=j;
end;
function BinToDec(Str: string): Integer;
var
Len, Res, i: Integer;
Error: Boolean;
begin
Error:=False;
Len:=Length(Str);
Res:=0;
for i:=1 to Len do
if (Str[i]='0')or(Str[i]='1') then
Res:=Res+Pow(2, Len-i)*StrToInt(Str[i])
else
begin
//MessageDlg('It is not a binary number', mtInformation, [mbOK], 0);
Error:=True;
Break;
end;
if Error=True then Result:=0
else Result:=Res;
end;
//------------------------------------------------------------------------------
function CRC16CCITT(bytes: array of Byte): Word;
const
polynomial = $1021;
var
crc: Word;
I, J: Integer;
b: Byte;
bit, c15: Boolean;
begin
crc := $FFFF;
for I := 0 to High(bytes) do
begin
b := bytes[I];
for J := 0 to 7 do
begin
bit := (((b shr (7-J)) and 1) = 1);
c15 := (((crc shr 15) and 1) = 1);
crc := crc shl 1;
if ((c15 xor bit) <> false) then crc := crc xor polynomial;
end;
end;
Result := crc and $ffff;
end;
//------------------------------------------------------------------------------
function HexToDec(const Str: string): Integer;
begin
if (Str <> '') and ((Str[1] = '-') or (Str[1] = '+')) then
Result := StrToInt(Str[1] + '$' + Copy(Str, 2, MaxInt))
else
Result := StrToInt('$' + Str);
end;
//------------------------------------------------------------------------------
function bin2crc16(str: string): string;
var
I:integer;
lengthCount : integer;
crcByteArr : array of Byte;
crcOut : Word;
begin
lengthCount := Trunc(length(str)/8);
setlength(crcByteArr , lengthCount );
for I := 0 to lengthCount-1 do
begin
crcByteArr[I] := BinToDec(copy(str, I*8+1, 8));
end;
crcOut := CRC16CCITT(crcByteArr);
result := crcOut.ToHexString;
end;
//------------------------------------------------------------------------------
function HexToBin(Hexadecimal: string): string;
const
BCD: array [0..15] of string =
('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',
'1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');
var
i: integer;
begin
Result := '';
for i := Length(Hexadecimal) downto 1 do
Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;
end;
but for android i changed the code to handle zero index string.
the result is different
memo2.Lines.Add( bin2crc16(HexToBin('1234')) ); //-----> 1AFa
here is used functions in android
function BinToDec(Str: string): Integer;
var
Len, Res, i: Integer;
Error: Boolean;
begin
Error:=False;
Len:=Length(Str);
Res:=0;
for i:=0 to Len-1 do
if (Str[i]='0')or(Str[i]='1') then
Res:=Res+Pow(2, Len-i)*StrToInt(Str[i])
else
begin
Error:=True;
Break;
end;
if Error=True then Result:=0
else Result:=Res;
end;
//------------------------------------------------------------------------------
function CRC16CCITT(bytes: array of Byte): Word;
const
polynomial = $1021;
var
crc: Word;
I, J: Integer;
b: Byte;
bit, c15: Boolean;
begin
crc := $FFFF;
for I := 0 to High(bytes) do
begin
b := bytes[I];
for J := 0 to 7 do
begin
bit := (((b shr (7-J)) and 1) = 1);
c15 := (((crc shr 15) and 1) = 1);
crc := crc shl 1;
if ((c15 xor bit) <> false) then crc := crc xor polynomial;
end;
end;
Result := crc and $ffff;
end;
//------------------------------------------------------------------------------
function bin2crc16(str: string): string;
var
I:integer;
lengthCount : integer;
crcByteArr : array of Byte;
crcOut : Word;
begin
lengthCount := Trunc(length(str)/8);
setlength(crcByteArr , lengthCount );
for I := 0 to lengthCount-1 do
begin
crcByteArr[I] := BinToDec(copy(str, I*8, 8));
end;
crcOut := CRC16CCITT(crcByteArr);
result := crcOut.ToHexString;
end;
//-----------------------------------------------------------------------------------
function HexToBin(Hexadecimal: string): string;
const
BCD: array [0..15] of string =
('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',
'1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');
var
i: integer;
begin
Result := '';
for i := Length(Hexadecimal)-1 downto 0 do
Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;
end;
//---------------------------------------------------------------------------------
function Pow(i, k: Integer): Integer;
var
j, Count: Integer;
begin
if k>0 then j:=2
else j:=1;
for Count:=1 to k-1 do
j:=j*2;
Result:=j;
end;
how can i fix my problem !?
You have not adjusted your HexToBin function for zero length strings.
There is also an issue in your BinToDec function. Your power calculation is wrong because the index into the string has changed. Possibly the simplest way to deal with it is as follows, although you could also adjust the index in the POW function
function BinToDec(Str: string): Integer;
var
Len, Res, i: Integer;
Error: Boolean;
begin
Error:=False;
Len:=Length(Str);
Res:=0;
for i:=1 to Len do
if (Str[I - 1]='0')or(Str[I - 1]='1') then
Res:=Res+Pow(2, Len-i)*StrToInt(Str[I - 1])
else
begin
Error:=True;
Break;
end;
if Error=True then Result:=0
else Result:=Res;
end;
The last thing to note is that 'Copy' uses One based indexing even on zero based strings, but you have assumed that it is zero indexed. I agree it is confusing, but there it is.
Anyone can help how can I transform this to work with tcxchecklistbox?
My Save procedure looks like...
procedure Tfrm_A.SaveCheckListBoxData(S: TMemoryStream;
CheckListBox: TCheckListBox);
var
i: longint;
b: boolean;
buf : string;
begin
S.Clear;
buf := CheckListBox.Items.Text;
i := Length(buf);
S.Write(i, SizeOf(i));
if i > 0 then begin
S.Write(buf[1], i);
for i:= 0 to Pred(CheckListBox.Items.Count) do
begin
b:= CheckListBox.Checked[i];
s.Write(b,1);
end;
end;
end;
My load procedure looks like...
procedure Tfrm_A.LoadCheckListBoxData(S: TMemoryStream;
CheckListBox: TChecklistBox);
var
i: longint;
b: Boolean;
buf : string;
begin
S.Position := 0;
S.Read(i, SizeOf(i));
if i > 0 then begin
SetLength(buf, i);
S.Read(buf[1], i);
CheckListBox.Items.Text := buf;
for i:= 0 to Pred(CheckListBox.Items.Count) do
begin
s.Read(b,1);
CheckListBox.Checked[i] := b;
end;
end;
end;
My problem is
buf := CheckListBox.Items.Text;
TcxChecklistbox has checklistbox.items[Index].textproperty
Thanks for the help!
You can use a TStringStream to do this. Basically, it's just a question of iterating the cxCheckBoxList Items and writing a character to the StringStream indicating whether the checkbox is checked, and then reading the stream back a character at a time.
function StateToString(Checked : Boolean) : String;
begin
if Checked then
Result := '+'
else
Result := '-';
end;
procedure TForm1.SaveStatesToStream(SS : TStringStream);
var
i : integer;
begin
SS.Clear;
SS.Position := 0;
for i := 0 to cxCheckListBox1.Items.Count - 1 do begin
SS.WriteString(StateToString(cxCheckListBox1.Items[i].Checked));
end;
Memo1.Lines.Add('>' + SS.DataString + '<');
end;
procedure TForm1.LoadStatesFromStream(SS : TStringStream);
var
i : integer;
S : String;
begin
CheckBoxList.ClearCheckmarks;
SS.Position := 0;
i := 0;
while (i <= cxCheckListBox1.Items.Count - 1) and (SS.Position < SS.Size) do begin
S := SS.ReadString(1);
cxCheckListBox1.Items[i].Checked := S = '+';
Inc(i);
end;
end;
Tested in Delphi Seattle
I have a line with the following description: '|0200|4|SALGADOS|||KG|00|19051000||||17|'
I want to separate where the pipe to save data in the database.
I'm using the pos function incorrectly. But I am getting the data.
Inside the if then i will insert data into db.
ReadLn(txt, line);
if True then
if (Pos('|0200|', line)) = 1 then
begin
fArq.Add(line);
end;
if (pos('|0000|', line)) = 1 then
begin
fArq.Add(line);
end;
if (pos('|0005|', line)) = 1 then
begin
fArq.Add(line);
end;
if (pos('|C460|', line)) = 1 then
begin
fArq.Add(line);
flagCF := True;
end
else
begin
if flagCF = True then
if (pos('|C490|', line)) = 0 then
fArq.Add(line)
else
flagCF := False;
end
You can also use TStringList:
lStringList := TStringList.Create;
lStringList.delimiter := '|';
lStringList.DelimitedText := '|0200|4|SALGADOS|||KG|00|19051000||||17|';
Now you can access each field using lStringList.Items[ index ]
Note (from comments): if space characters is included in the string, set StrictDelimiter to true to avoid treating them as delimiters.
With ExtractStrings, you can add all values between the |'s to a TStrings-descendant.
Assuming fArq is a TStrings descendent:
ExtractStrings(['|'], [], PChar(line), fArq);
If you use Delphi XE3 and up you can use the Split Class Helper Method.
parts:=line.Split(['|'],TStringSplitOptions.ExcludeEmpty);
I have the following functions that I've been using for quite some time.
There are two variants here, the first one is a one time use type of function and the other is when you want to efficiently process the entire input string from the first element up to the last in order.
I have also included the related functions to count the number of sections.
P.S. These functions are actually 1 based, as written.
P.P.S. I ripped the functions from another unit and haven't checked this unit for complete correctness. YMMV.
The non POS methods are considered one-off functions. ie. You are only looking for a single value in the given input string.
The POS methods take two addition integer variables to store internal index positions for later use. The initial value of the variables should be set to -1 for the first call. After that you should just provide the values to the next iteration of the call that the previous call returned.
For example.
Non-POS use:
const
Str1 = '|0200|4|SALGADOS|||KG|00|19051000||||17|';
.
.
.
begin
showmessage( ParseSection(Str1, 1, '|') ); //returns 0200
showmessage( ParseSection(Str1, 4, '|') ); //returns '' (empty string)
//this will show every element in the string once
Idx1 := -1;
Idx2 := -1;
for loop := 1 to CountSections(Str1, '|') do
showmessage( ParseSectionPos(Str1, loop, '|', Idx1, Idx2) );
//Idx1 and Idx2 are self referenced variables and don't need outside intervention
//These are necessary to obtain the best possible speed
end;
The other variations of the methods allow for quoted values and the quoting character to be user defined.
unit rmControls.Strings.Sections;
interface
uses System.Classes, System.SysUtils;
function CountSections(const ParseLine: string; const ParseSep: char): integer; overload;
function CountSections(const ParseLine: string; const ParseSep: char; const QuotedStrChar: char): integer; overload;
function ParseSection(const ParseLine: string; ParseNum: integer; const ParseSep: char): string; overload;
function ParseSection(const ParseLine: string; ParseNum: integer; const ParseSep: char; const QuotedStrChar: char): string; overload;
function ParseSectionPos(const ParseLine: string; ParseNum: integer; const ParseSep: char; var FromIDX, FromPOS: integer): string; overload;
function ParseSectionPos(const ParseLine: string; ParseNum: integer; const ParseSep: char; const QuotedStrChar: char; var FromIDX, FromPOS: integer): string; overload;
function UpdateSection(const ParseLine, UpdateText: string; ParseNum: integer; const ParseSep: char):string; overload;
function UpdateSection(const ParseLine, UpdateText: string; ParseNum: integer; const ParseSep: char; const QuotedStrChar: char):string; overload;
function UpdateSectionPos(const ParseLine, UpdateText: string; ParseNum: integer; const ParseSep: char; var FromIDX, FromPOS: integer):string; overload;
function UpdateSectionPos(const ParseLine, UpdateText: string; ParseNum: integer; const ParseSep: char; const QuotedStrChar: char; var FromIDX, FromPOS: integer):string; overload;
implementation
uses System.Math, System.Masks, System.Character, System.Variants;
function CountSections(const ParseLine: string; const ParseSep: char; const QuotedStrChar: char): integer; overload;
var
wEnd: PChar;
Loop: integer;
wInQuote: boolean;
begin
wInQuote := false;
wEnd := PChar(ParseLine);
result := 0;
for Loop := 1 to Length(ParseLine) do
begin
if (wEnd^ = QuotedStrChar) then
wInQuote := not wInQuote;
if not wInQuote and (wEnd^ = ParseSep) then
inc(result);
inc(wEnd);
end;
if Length(ParseLine) <> 0 then
inc(result);
end; { CountSections }
function CountSections(const ParseLine: string; const ParseSep: char): integer; overload;
var
wEnd: PChar;
Loop: integer;
begin
wEnd := PChar(ParseLine);
result := 0;
for Loop := 1 to Length(ParseLine) do
begin
if (wEnd^ = ParseSep) then
inc(result);
inc(wEnd);
end;
if Length(ParseLine) <> 0 then
inc(result);
end; { CountSections }
function ParseSection(const ParseLine: string; ParseNum: integer; const ParseSep: char): string; overload;
var
w1, w2: integer;
begin
w1 := -1;
w2 := -1;
result := ParseSectionPos(ParseLine, ParseNum, ParseSep, w1, w2);
end; { ParseSection }
function ParseSection(const ParseLine: string; ParseNum: integer; const ParseSep: char; const QuotedStrChar: char): string; overload;
var
w1, w2: integer;
begin
w1 := -1;
w2 := -1;
result := ParseSectionPos(ParseLine, ParseNum, ParseSep, QuotedStrChar, w1, w2);
end; { ParseSection }
function ParseSectionPos(const ParseLine: string; ParseNum: integer; const ParseSep: char; var FromIDX, FromPOS: integer): string;
var
wStart, wEnd: PChar;
wIndex, Loop: integer;
wLoopIDX: integer;
begin
wIndex := 1;
wLoopIDX := 1;
wEnd := PChar(ParseLine);
if (FromIDX > -1) and (FromIDX < Length(ParseLine)) then
begin
inc(wEnd, FromIDX);
wIndex := FromPOS;
wLoopIDX := FromIDX;
end;
wStart := wEnd;
for Loop := wLoopIDX to Length(ParseLine) do
begin
if (wEnd^ = ParseSep) then
begin
if wIndex = ParseNum then
break
else
begin
inc(wIndex);
inc(wEnd);
wStart := wEnd;
end;
end
else
inc(wEnd);
end;
if wIndex = ParseNum then
begin
SetString(result, wStart, wEnd - wStart);
if result = #0 then
result := '';
FromIDX := wEnd - PChar(ParseLine);
FromPOS := ParseNum;
end
else
result := '';
end;
function ParseSectionPos(const ParseLine: string; ParseNum: integer; const ParseSep: char; const QuotedStrChar: char; var FromIDX, FromPOS: integer): string;
var
wStart, wEnd: PChar;
wIndex, Loop: integer;
wInQuote: boolean;
wLoopIDX: integer;
begin
wInQuote := false;
wIndex := 1;
wLoopIDX := 1;
wEnd := PChar(ParseLine);
if (FromIDX > -1) and (FromIDX < Length(ParseLine)) then
begin
inc(wEnd, FromIDX);
wIndex := FromPOS;
wLoopIDX := FromIDX;
end;
wStart := wEnd;
for Loop := wLoopIDX to Length(ParseLine) do
begin
if (wEnd^ = QuotedStrChar) then
wInQuote := not wInQuote;
if not wInQuote and (wEnd^ = ParseSep) then
begin
if wIndex = ParseNum then
break
else
begin
inc(wIndex);
inc(wEnd);
wStart := wEnd;
end;
end
else
inc(wEnd);
end;
if wIndex = ParseNum then
begin
SetString(result, wStart, wEnd - wStart);
if (Length(result) > 0) and (result[1] = QuotedStrChar) then
result := AnsiDequotedStr(result, QuotedStrChar);
if result = #0 then
result := '';
FromIDX := wEnd - PChar(ParseLine);
FromPOS := ParseNum;
end
else
result := '';
end;
function UpdateSection(const ParseLine, UpdateText: string; ParseNum: integer; const ParseSep: char): string; overload;
var
w1, w2: integer;
begin
w1 := -1;
w2 := -1;
result := UpdateSectionPos(ParseLine, UpdateText, ParseNum, ParseSep, w1, w2);
end;
function UpdateSection(const ParseLine, UpdateText: string; ParseNum: integer; const ParseSep: char; const QuotedStrChar: char): string; overload;
var
w1, w2: integer;
begin
w1 := -1;
w2 := -1;
result := UpdateSectionPos(ParseLine, UpdateText, ParseNum, ParseSep, QuotedStrChar, w1, w2);
end;
function UpdateSectionPos(const ParseLine, UpdateText: string; ParseNum: integer; const ParseSep: char; var FromIDX, FromPOS: integer):string; overload;
var
wStart, wEnd: PChar;
wIndex, Loop: integer;
wLoopIDX: integer;
begin
wIndex := 1;
wLoopIDX := 1;
wEnd := PChar(ParseLine);
if (FromIDX > -1) and (FromIDX < Length(ParseLine)) then
begin
inc(wEnd, FromIDX);
wIndex := FromPOS;
wLoopIDX := FromIDX;
end;
wStart := wEnd;
for Loop := wLoopIDX to Length(ParseLine) do
begin
if (wEnd^ = ParseSep) then
begin
if wIndex = ParseNum then
break
else
begin
inc(wIndex);
inc(wEnd);
wStart := wEnd;
end;
end
else
inc(wEnd);
end;
if wIndex = ParseNum then
begin
SetString(result, PChar(ParseLine), wStart - pChar(ParseLine));
if result = #0 then
result := '';
result := result + updateText + pchar(wEnd);
FromIDX := wEnd - PChar(ParseLine);
FromPOS := ParseNum;
end
else
raise Exception.Create('Index not found');
end;
function UpdateSectionPos(const ParseLine, UpdateText: string; ParseNum: integer; const ParseSep: char; const QuotedStrChar: char; var FromIDX, FromPOS: integer):string; overload;
var
wStart, wEnd: PChar;
wIndex, Loop: integer;
wInQuote: boolean;
wLoopIDX: integer;
begin
wInQuote := false;
wIndex := 1;
wLoopIDX := 1;
wEnd := PChar(ParseLine);
if (FromIDX > -1) and (FromIDX < Length(ParseLine)) then
begin
inc(wEnd, FromIDX);
wIndex := FromPOS;
wLoopIDX := FromIDX;
end;
wStart := wEnd;
for Loop := wLoopIDX to Length(ParseLine) do
begin
if (wEnd^ = QuotedStrChar) then
wInQuote := not wInQuote;
if not wInQuote and (wEnd^ = ParseSep) then
begin
if wIndex = ParseNum then
break
else
begin
inc(wIndex);
inc(wEnd);
wStart := wEnd;
end;
end
else
inc(wEnd);
end;
if wIndex = ParseNum then
begin
SetString(result, PChar(ParseLine), wStart - pChar(ParseLine));
if result = #0 then
result := '';
result := result + AnsiQuotedStr(updateText, QuotedStrChar) + pchar(wEnd);
FromIDX := wEnd - PChar(ParseLine);
FromPOS := ParseNum;
end
else
raise Exception.Create('Index not found');
end;
end.
Here's the function I use. It supports any-length delimiter (for splitting CRLF-separated string, f.i.) and AllowEmpty parameter which determines whether empty elements would be omitted or returned.
function Split(const Str: string; Delim: string; AllowEmpty: Boolean): TStringDynArray;
var CurrDelim, NextDelim, CurrIdx: Integer;
begin
if Str = '' then begin SetLength(Result, 0); Exit; end;
CurrDelim := 1; CurrIdx := 0; SetLength(Result, 16);
repeat
if CurrIdx = Length(Result) then
SetLength(Result, CurrIdx + 16);
NextDelim := PosEx(Delim, Str, CurrDelim);
if NextDelim = 0 then NextDelim := Length(Str)+1; // the end of the string
Result[CurrIdx] := Copy(Str, CurrDelim, NextDelim - CurrDelim);
CurrDelim := NextDelim + Length(Delim);
if (Result[CurrIdx] <> '') or AllowEmpty
then Inc(CurrIdx)
else Continue;
until CurrDelim > Length(Str);
SetLength(Result, CurrIdx); // cut the array to actual length
end;
In Delphi XE3 I am trying to decode some data being read from a UDP-socket.
Apparently the data encoded like this (chronological order as listed):
NAME BITS TYPE
RECURRENCE INDICATOR 1 BOOLEAN
TRANSMITTER CODE 24 STRING
LATITUDE 25 INTEGER
LONGITUDE 26 INTEGER
DERIVATION 4 INTEGER
//I am not able to reach the documentation from work but the lat and long
//translates with a constant of 0.00000536441, so you take the binary (2 based)
//number, convert to decimal (10 based) and multiply with the constant for the
//float value of the coordinates.
Per now, my code looks like this (yes- this is early stage test and manual calculations):
procedure TForm1.UDPUDPRead(AThread: TIdUDPListenerThread; AData: array of Byte;
ABinding: TIdSocketHandle);
var
s: string;
recInd: Boolean;
trCode: String;
lat, long, deri: Integer;
begin
Label1.Caption := IntToStr(Length(AData)) + ' bytes received # ' +
TimeToStr(Time);
s := BytesToHex(AData);
If CheckBox2.Checked Then Memo1.Lines.Clear;
Memo1.Lines.Add(s);
end;
The questions is how can I set the variables recInd, trCode, lat, long and deri from that array of bytes?
Desired function would be someting like:
function SubBin(AData: array of byte; start, length: integer):array of byte
//Used like this:
recInd := SubBin(AData, 0, 1);
trCode := SubBin(AData, 1, 24);
lat := SubBin(AData, 25, 25);
long := SubBin(AData, 50, 26);
deri := SubBin(AData, 76, 4);
Assuming bit order MSB first, you can try something like this (not debugged, not optimized, just as an idea):
function ExtractBitArray(AData:TBytes; AFrom,ALength:Integer): TBytes;
var
ByteIdxFrom: integer;
i: integer;
BitEndOfs: integer;
Mask: byte;
procedure ___ShiftBytesRight(var ABuf:TBytes);
var
CFhi,CFlo: Byte;
B: byte;
i: integer;
begin
CFHi := 0;
for i := low(ABuf) to high(ABuf) do
begin
B := ABuf[i];
CFlo := B;
B := (B shr 1) or CFhi;
ABuf[i] := B;
CFhi := CFlo shl 7 and $80;
end;
end;
begin
ByteIdxFrom := AFrom div 8;
BitEndOfs := (AFrom + ALength) mod 8;
//
SetLength(Result,ALength div 8 + 1);
for i := Low(Result) to High(Result) do
Result[i] := AData[ByteIdxFrom + i];
//
if BitEndOfs>0 then
for I := BitEndOfs to 7 do
___ShiftBytesRight(Result);
//
Mask := $FF;
for i := ALength mod 8 to 7 do
Mask := Mask shr 1;
Result[0] := Result[0] and Mask;
end;
I finally came up with something in general looking like this:
procedure decode(adata: array of bytes; var results: Tcustom_record);
var
bstream: TBitStream;
buffer: Tbytes;
ALen: integer;
begin
ALen := Length(AData);
SetLength(buffer, ALen);
if ALen <> 0 then begin
Move(AData[0], buffer[0], ALen);
end;
bstream:=TBitStream.Create;
bstream.Load(buffer, sizeof(buffer) );
results.RECURRENCE_INDICATOR :=bstream.readBit;
results.TRANSMITTER_CODE :=bstream.readCardinal(24);
results.LATITUDE :=bstream.readCardinal(25);
results.LONGITUDE :=bstream.readCardinal(26);
results.DERIVATION :=bstream.readCardinal(4);
after digging down in the code i found i realized that TBitStream has to be defined:
unit ubitstream;
interface
uses classes,sysutils;
Type
TBitStream = class
constructor Create;
destructor Free;
public
procedure clear;
procedure Load(fileName: string); overload;
procedure Load(bs:TBitStream; offset: cardinal; count:cardinal); overload;
procedure Load(bs:TBitStream; count:cardinal); overload;
procedure Load(byteArray: TBytes); overload;
procedure Load(byteArray: TBytes; offset:cardinal); overload;
procedure Save(fileName: string); overload;
procedure Save(var byteArray: TBytes); overload;
function toHex:String;
function toBin:String;
//Sequental Access
function readCardinal(count: integer):cardinal;
function readBit:byte;
function readString(count:cardinal):ansistring;
procedure writeBit(bit: byte);
procedure writeBits(count: cardinal; data: TBytes); overload;
procedure writeBits(count: cardinal; pdata: Pbyte); overload;
procedure writeString(s: ansistring);
//----------------------------------------------------
function getSize:smallint;
procedure setSize(newSize: smallint);
property Size: smallint read getSize write setSize;
function getPos: cardinal;
procedure setPos(newPosition: cardinal);
property Position: cardinal read getPos write setPos;
function eos:boolean;//End Of Stream
protected
//Random Access
function getCardinal(offset: cardinal; count: cardinal):cardinal;
function getBit(offset: cardinal):byte;
function getString(offset: cardinal; count:cardinal; var readCount: cardinal):ansistring;
procedure setBit(offset: cardinal; bit: byte);
procedure setBits(offset: cardinal; count: cardinal; data: TBytes);
//----------------------------------------------------
private
bits: Array of byte;
stream_pos: cardinal; //postinion for sequental operations bits-based
end;
implementation
constructor TBitStream.Create;
begin
SetLength(bits,1); //initial size is 1b
stream_pos := 0;
end;
destructor TBitStream.Free;
begin
SetLength(bits,0); //free array
end;
procedure TBitStream.clear;
// clear data
begin
SetLength(bits,1);
bits[0] := 0;
stream_pos := 0;
end;
function TBitStream.getSize:smallint;
begin
getSize := High(bits) + 1; //index is zero-based
end;
procedure TBitStream.setSize(newSize: smallint);
begin
SetLength(bits,newSize);
if stream_pos>newSize-1 then stream_pos:=High(bits)+1;
end;
function TBitStream.getCardinal(offset: cardinal; count: cardinal):cardinal;
//return count of bits from ofsset as 32-bit data type
//offset and count size in bits
var
res: cardinal;
i,shift: cardinal;
begin
getCardinal:=0;
if (offset+count>Size*8) then raise Exception.Create('Index out of array bounds!');
if count>32 then exit; //no more than 32-bit
res := getBit(offset);
// writeln(offset,' ',getBit(offset),' ',res);
shift := 1;
for i:=offset+1 to offset+count-1 do begin
res := res or (getBit(i) shl shift);
inc(shift);
// writeln(i,' ',getBit(i),' ',res);
end;
getCardinal := res;
end;
procedure TBitStream.setBit(offset: cardinal; bit: byte);
//offset in bits
var
b: byte;
off1: cardinal;
pos1: byte;
begin
if (offset>=Size*8) then SetLength(bits,(offset div 8)+1);
off1 := offset div 8;
pos1 := offset mod 8;
b := bits[off1];
if bit=0 then begin //drop bit
b := b and (not (1 shl pos1));
end else begin //set bit
b := b or (1 shl pos1);
end;
bits[off1] := b;
end;
procedure TBitStream.setBits(offset: cardinal; count: cardinal; data: TBytes);
//set count of bits at ofsset from bytes array
//offset and count size in bits
var
i,j: cardinal;
b,bit: byte;
byteCount: cardinal;
off: cardinal;
Label STOP;
begin
if (offset+count>=Size*8) then SetLength(bits,((offset+count) div 8)+1); //Reallocate bits array
byteCount := count div 8;
off := offset;
if (count mod 8)>0 then inc(byteCount);
for i:=0 to byteCount-1 do begin //dynamic arrays is zero-based
b := data[i];
for j:=0 to 7 do begin //all bits in byte
bit := (b and (1 shl j)) shr j;
setBit(off,bit);
inc(off);
if (off>offset+count) then goto STOP;
end;
end;
STOP:
end;
function TBitStream.getBit(offset: cardinal):byte;
//offset in bits
var
b: byte;
off1: cardinal;
pos1: byte;
begin
getBit := 0;
if (offset>Size*8) then raise Exception.Create('Index out of array bounds!');
off1 := offset div 8;
pos1 := offset mod 8;
// if (offset mod 8)>0 then inc(off1);
b := bits[off1];
b := (b and (1 shl pos1)) shr pos1;//get bit
getBit := b;
end;
function TBitStream.getString(offset: cardinal; count:cardinal; var readCount: cardinal):ansistring;
//count, odffset in bits
var
s: ansistring;
len,i: cardinal;
b: byte;
off: cardinal;
begin
getString:='';
s := '';
readCount := 0;
off := offset;
if (count mod 7)<>0 then exit; //string must contain 7-bits chars....
len := count div 7;
for i:=1 to len do begin
if (offset>Size*8) then raise Exception.Create('Index out of array bounds!');
b := getCardinal(off,7);
inc(off,7);
inc(readCount,7);
if b=$7F then break; //this is EOL code
s := s + ansichar(b);
end;
getString := s;
end;
function TBitStream.toHex:String;
var
i:integer;
s,res:string;
begin
res:='';
for i:=Low(bits) to High(bits) do begin
s := Format('%02.2X ',[bits[i]]);
res := res + s;
end;
toHex := res;
end;
function TBitStream.toBin:String;
var
i,j:integer;
s,res:string;
b: byte;
begin
res:='';
for i:=Low(bits) to High(bits) do begin
//s := Format('%02.2X',[bits[i]]);
b := bits[i];
s:='';
for j:=7 downto 0 do begin
if (b and (1 shl j))>0 then s:=s+'1' else s:=s+'0';
end;
s := s+' ';
res := res + s;
end;
toBin := res;
end;
procedure TBitStream.Load(fileName: string);
//load data from binary file
var
f: file of byte;
i: cardinal;
b: byte;
begin
clear;
i:=0;
assign(f,fileName);
reset(f);
while not eof(f) do begin
blockread(f,b,1);
SetLength(bits,i+1);
bits[i] := b;
inc(i);
end;
close(f);
end;
procedure TBitStream.Save(fileName: string);
//save data to binary file
var
i:cardinal;
f: file of byte;
b: byte;
begin
assign(f,fileName);
rewrite(f);
for i:=Low(bits) to High(bits) do begin
b := bits[i];
blockwrite(f,b,1);
end;
close(f);
end;
procedure TBitStream.Save(var byteArray: TBytes);
//save data to array of bytes
var
i: cardinal;
begin
SetLength(byteArray,Size);
for i:=0 to Size-1 do begin
byteArray[i] := bits[i];
end;
end;
procedure TBitStream.Load(bs:TBitStream; offset: cardinal; count: cardinal);
//load data from other stream
//offset/count in bits
var
i,len,off: cardinal;
b: byte;
begin
clear;
off := offset;
len := count div 8;
setLength(bits, len);
for i:=0 to len-1 do begin
b:=bs.getCardinal(off,8);
if (i>Size) then SetLength(bits,i+1);
bits[i] := b;
inc(off,8);
end;
end;
procedure TBitStream.Load(bs:TBitStream; count: cardinal);
//load data from other stream
//count in bits
begin
Load(bs, bs.Position, count);
bs.Position:=bs.Position+count;
end;
procedure TBitStream.Load(byteArray: TBytes);
//load data from array of bytes
var
i,len: cardinal;
begin
clear;
len := High(byteArray)+1;
setLength(bits, len);
for i:=0 to len-1 do begin
bits[i] := byteArray[i];
end;
end;
procedure TBitStream.Load(byteArray: TBytes; offset:cardinal);
//offset in bytes
var
i,len: cardinal;
begin
clear;
len := High(byteArray)+1;
if offset>len then exit;
setLength(bits, len-offset);
for i:=offset to len-1 do begin
bits[i-offset] := byteArray[i];
end;
end;
function TBitStream.getPos: cardinal;
begin
getPos := stream_pos;
end;
procedure TBitStream.setPos(newPosition: cardinal);
begin
stream_pos := newPosition;
end;
function TBitStream.readCardinal(count: integer):cardinal;
begin
readCardinal := getCardinal(stream_pos, count);
inc(stream_pos,count);
end;
function TBitStream.readBit:byte;
begin
readBit := getBit(stream_pos);
inc(stream_pos);
end;
function TBitStream.readString(count:cardinal):ansistring;
//count in bits
var readCount: cardinal;
begin
readString := getString(stream_pos,count,readCount);
inc(stream_pos,readCount);
end;
procedure TBitStream.writeBit(bit: byte);
begin
setBit(stream_pos,bit);
inc(stream_pos);
end;
procedure TBitStream.writeBits(count: cardinal; data: TBytes);
begin
setBits(stream_pos,count,data);
inc(stream_pos,count);
end;
procedure TBitStream.writeBits(count: cardinal; pdata: pbyte);
var
i:cardinal;
len:cardinal;
bytes: TBytes;
begin
len:=count div 8;
if (count mod 8)>0 then inc(len);
setLength(bytes,len);
for i:=0 to len-1 do begin
bytes[i]:=pdata^;
inc(pdata);
end;
writeBits(count,bytes);
end;
function TBitStream.eos:boolean;
begin
eos := stream_pos=High(bits)+1;
end;
procedure TBitStream.writeString(s: ansistring);
var
i:cardinal;
c: byte;
eos:byte;
begin
for i:=1 to length(s) do begin
c:=byte(s[i]);
setBits(stream_pos,7,TBytes(#c));
inc(stream_pos,7);
end;
eos:=$7f;
setBits(stream_pos,7,TBytes(#eos));
inc(stream_pos,7);
end;
end.