From c20b15a4c010fa8dcd983f36f94f5654db25bdfc Mon Sep 17 00:00:00 2001 From: crutchy- Date: Sat, 3 Jan 2015 22:44:53 +1100 Subject: [PATCH] whatever i changed --- delphi/lib/JMC_FileSearch.pas | 616 +++++++++++++++++++ delphi/lib/JMC_FileUtils.pas | 116 ++++ delphi/lib/JMC_Graphics.pas | 682 +++++++++++++++++++++ delphi/lib/JMC_HTTP_NonBlocking.pas | 573 ++++++++++++++++++ delphi/lib/JMC_Math.pas | 35 ++ delphi/lib/JMC_Messaging.pas | 323 ++++++++++ delphi/lib/JMC_NetworkUtils.pas | 71 +++ delphi/lib/JMC_Parts.pas | 189 ++++++ delphi/lib/JMC_PathFinding.pas | 165 ++++++ delphi/lib/JMC_Processes.pas | 188 ++++++ delphi/lib/JMC_SocketMessaging.pas | 338 +++++++++++ delphi/lib/JMC_Strings.pas | 888 ++++++++++++++++++++++++++++ delphi/lib/JMC_SysUtils.pas | 45 ++ delphi/lib/JMC_Utils.pas | 370 ++++++++++++ delphi/lib/JMC_WinAPI.pas | 158 +++++ delphi/lib/Utils.pas | 44 ++ 16 files changed, 4801 insertions(+) create mode 100644 delphi/lib/JMC_FileSearch.pas create mode 100644 delphi/lib/JMC_FileUtils.pas create mode 100644 delphi/lib/JMC_Graphics.pas create mode 100644 delphi/lib/JMC_HTTP_NonBlocking.pas create mode 100644 delphi/lib/JMC_Math.pas create mode 100644 delphi/lib/JMC_Messaging.pas create mode 100644 delphi/lib/JMC_NetworkUtils.pas create mode 100644 delphi/lib/JMC_Parts.pas create mode 100644 delphi/lib/JMC_PathFinding.pas create mode 100644 delphi/lib/JMC_Processes.pas create mode 100644 delphi/lib/JMC_SocketMessaging.pas create mode 100644 delphi/lib/JMC_Strings.pas create mode 100644 delphi/lib/JMC_SysUtils.pas create mode 100644 delphi/lib/JMC_Utils.pas create mode 100644 delphi/lib/JMC_WinAPI.pas create mode 100644 delphi/lib/Utils.pas diff --git a/delphi/lib/JMC_FileSearch.pas b/delphi/lib/JMC_FileSearch.pas new file mode 100644 index 0000000..3ba9a97 --- /dev/null +++ b/delphi/lib/JMC_FileSearch.pas @@ -0,0 +1,616 @@ +unit JMC_FileSearch; + +//////////////////////////////////////////////////////////////////////////////// +// // +// Jared Crutchfield's Delphi Library // +// // +// JMC_FileSearch Library Unit // +// // +// Modified 29/09/2011 // +// // +//////////////////////////////////////////////////////////////////////////////// + +interface + +uses + Classes, + SysUtils, + Windows, + Dialogs, + Forms, + ComCtrls, + Graphics, + ExtCtrls, + Controls, + ShellAPI; + +type + + TJMC_File = class; + TJMC_Folder = class; + TJMC_FileManager = class; + + TJMC_FileAttribute = (JMC_faReadOnly, JMC_faHidden, JMC_faSysFile, JMC_faVolumeID, JMC_faDirectory, JMC_faArchive, JMC_faAnyFile); + TJMC_FileAttributes = set of TJMC_FileAttribute; + + TJMC_AddFileEvent = procedure(const Sender: TObject; const AddedFile: TJMC_File) of object; + TJMC_AddFolderEvent = procedure(const Sender: TObject; const AddedFolder: TJMC_Folder) of object; + TJMC_AllowAddFileEvent = function(const FileName: string): Boolean of object; + + TJMC_File = class(TObject) + private + FAttributes: TJMC_FileAttributes; + FExtension: string; + FFileName: string; + FFolder: TJMC_Folder; + FName: string; + FSize: Integer; + FTime: TDateTime; + public + constructor Create(const Folder: TJMC_Folder; const SearchRec: TSearchRec); + public + property Attributes: TJMC_FileAttributes read FAttributes; + property Extension: string read FExtension; + property FileName: string read FFileName; + property Folder: TJMC_Folder read FFolder; + property Name: string read FName; + property Size: Integer read FSize; + property Time: TDateTime read FTime; + end; + + TJMC_Folder = class(TObject) + private + FAttributes: TJMC_FileAttributes; + FChildren: TList; + FFileManager: TJMC_FileManager; + FFiles: TList; + FItems: TList; + FName: string; + FParent: TJMC_Folder; + FPath: string; + FTime: TDateTime; + private + function GetChild(const Index: Integer): TJMC_Folder; + function GetChildCount: Integer; + function GetFile(const Index: Integer): TJMC_File; + function GetFileCount: Integer; + function GetItem(const Index: Integer): TObject; + function GetItemCount: Integer; + function GetItemName(const Index: Integer): string; + procedure SetPath(const Value: string); + public + constructor Create(const Parent: TJMC_Folder); + destructor Destroy; override; + public + procedure Clear; + procedure Fill(const SearchRec: TSearchRec); + function ItemIndex(const Item: TObject): Integer; + public + property Attributes: TJMC_FileAttributes read FAttributes; + property ChildCount: Integer read GetChildCount; + property Children[const Index: Integer]: TJMC_Folder read GetChild; + property FileCount: Integer read GetFileCount; + property FileManager: TJMC_FileManager read FFileManager write FFileManager; + property Files[const Index: Integer]: TJMC_File read GetFile; + property ItemCount: Integer read GetItemCount; + property ItemNames[const Index: Integer]: string read GetItemName; + property Items[const Index: Integer]: TObject read GetItem; + property Name: string read FName; + property Parent: TJMC_Folder read FParent; + property Path: string read FPath write SetPath; + property Time: TDateTime read FTime; + end; + + TJMC_FileManager = class(TObject) + private + FCancelled: Boolean; + FPaths: TStrings; + FRootFolders: TList; + private + FOnAddFile: TJMC_AddFileEvent; + FOnAddFolder: TJMC_AddFolderEvent; + FOnAllowAddFile: TJMC_AllowAddFileEvent; + FOnFinish: TNotifyEvent; + private + function GetRootFolder(const Index: Integer): TJMC_Folder; + function GetRootFolderCount: Integer; + public + constructor Create; + destructor Destroy; override; + public + function AllowAddFile(const FileName: string): Boolean; + procedure CallAddFile(const AddedFile: TJMC_File); + procedure CallAddFolder(const AddedFolder: TJMC_Folder); + procedure Cancel; + procedure ClearRootFolders; + procedure Refresh; + public + property Cancelled: Boolean read FCancelled; + property Paths: TStrings read FPaths; + property RootFolderCount: Integer read GetRootFolderCount; + property RootFolders[const Index: Integer]: TJMC_Folder read GetRootFolder; default; + public + property OnAddFile: TJMC_AddFileEvent read FOnAddFile write FOnAddFile; + property OnAddFolder: TJMC_AddFolderEvent read FOnAddFolder write FOnAddFolder; + property OnAllowAddFile: TJMC_AllowAddFileEvent read FOnAllowAddFile write FOnAllowAddFile; + property OnFinish: TNotifyEvent read FOnFinish write FOnFinish; + end; + + TJMC_TreeViewManager = class(TObject) + private + FFileManager: TJMC_FileManager; + FTreeView: TTreeView; + private + procedure CreateTreeViewFolder(const Folder: TJMC_Folder; const Parent: TTreeNode); + public + constructor Create(const TreeView: TTreeView); + destructor Destroy; override; + public + procedure FillTreeView; + public + property FileManager: TJMC_FileManager read FFileManager; + property TreeView: TTreeView read FTreeView; + end; + +function SwapPaths(const CurrentFileNamePath: string; const NewFileNamePath: string; const FileName: string): string; +function Search(const TreeView: TTreeView; const FileName: string): TTreeNode; +procedure TreeViewCollapsed(Sender: TObject; Node: TTreeNode); +procedure TreeViewExpanded(Sender: TObject; Node: TTreeNode); +procedure AssignShellIcons(const ImageList: TImageList); +function ExpandPath(const MasterFileName, SlaveFileName: string): string; +function SettingsFileName: string; + +const + JMC_ICON_FOLDERCLOSED: Integer = 0; + JMC_ICON_FOLDEROPEN: Integer = 1; + JMC_ICON_FILE: Integer = 2; + JMC_ICONID_FOLDERCLOSED: Cardinal = 3; + JMC_ICONID_FOLDEROPEN: Cardinal = 4; + JMC_ICONID_FILE: Cardinal = 224; + JMC_ICON_EXENAME: string = 'shell32.dll'; + +implementation + +function SwapPaths(const CurrentFileNamePath: string; const NewFileNamePath: string; const FileName: string): string; +var + P1: string; + P2: string; + S: string; +begin + Result := ''; + P1 := IncludeTrailingPathDelimiter(CurrentFileNamePath); + P2 := IncludeTrailingPathDelimiter(NewFileNamePath); + if Pos(UpperCase(CurrentFileNamePath), UpperCase(FileName)) <= 0 then + Exit; + S := FileName; + Delete(S, 1, Length(CurrentFileNamePath)); + S := P2 + S; + Result := S; +end; + +function Search(const TreeView: TTreeView; const FileName: string): TTreeNode; +var + F: TJMC_File; + N: TTreeNode; +begin + Result := nil; + if (TreeView.Items.Count = 0) or (FileExists(FileName) = False) then + Exit; + N := TreeView.Items.GetFirstNode; + while N <> nil do + begin + Application.ProcessMessages; + if Application.Terminated then + Exit; + if N.Data <> nil then + if TObject(N.Data) is TJMC_File then + begin + F := TJMC_File(N.Data); + if UpperCase(FileName) = UpperCase(F.FileName) then + begin + Result := N; + Exit; + end; + end; + N := N.GetNext; + end; +end; + +procedure TreeViewCollapsed(Sender: TObject; Node: TTreeNode); +begin + Node.ImageIndex := JMC_ICON_FOLDERCLOSED; + Node.SelectedIndex := JMC_ICON_FOLDERCLOSED; +end; + +procedure TreeViewExpanded(Sender: TObject; Node: TTreeNode); +begin + Node.ImageIndex := JMC_ICON_FOLDEROPEN; + Node.SelectedIndex := JMC_ICON_FOLDEROPEN; +end; + +procedure AssignShellIcons(const ImageList: TImageList); +var + Buf: Graphics.TPicture; + P1, P2: HICON; +begin + Buf := Graphics.TPicture.Create; + try + if ExtractIconEx(PChar(JMC_ICON_EXENAME), JMC_ICONID_FOLDERCLOSED, P1, P2, 1) <> 1 then + begin + Buf.Icon.Handle := P2; + ImageList.AddIcon(Buf.Icon); + end; + if ExtractIconEx(PChar(JMC_ICON_EXENAME), JMC_ICONID_FOLDEROPEN, P1, P2, 1) <> 1 then + begin + Buf.Icon.Handle := P2; + ImageList.AddIcon(Buf.Icon); + end; + if ExtractIconEx(PChar(JMC_ICON_EXENAME), JMC_ICONID_FILE, P1, P2, 1) <> 1 then + begin + Buf.Icon.Handle := P2; + ImageList.AddIcon(Buf.Icon); + end; + finally + Buf.Free; + end; +end; + +function ExpandPath(const MasterFileName, SlaveFileName: string): string; +var + S: string; +begin + GetDir(0, S); + try + ChDir(ExtractFilePath(MasterFileName)); + except + Result := ''; + Exit; + end; + Result := ExpandFilename(SlaveFileName); + ChDir(S); +end; + +function SettingsFileName: string; +begin + Result := ChangeFileExt(ParamStr(0), '.ini'); +end; + +function AttrToJMCAttr(const Attr: Integer): TJMC_FileAttributes; +begin + Result := []; + if (Attr and faReadOnly) > 0 then + Include(Result, JMC_faReadOnly); + if (Attr and faHidden) > 0 then + Include(Result, JMC_faHidden); + if (Attr and faSysFile) > 0 then + Include(Result, JMC_faSysFile); + if (Attr and faVolumeID) > 0 then + Include(Result, JMC_faVolumeID); + if (Attr and faDirectory) > 0 then + Include(Result, JMC_faDirectory); + if (Attr and faArchive) > 0 then + Include(Result, JMC_faArchive); + if (Attr and faAnyFile) > 0 then + Include(Result, JMC_faAnyFile); +end; + +{ TJMC_File } + +constructor TJMC_File.Create(const Folder: TJMC_Folder; const SearchRec: TSearchRec); +var + i: Integer; +begin + FFolder := Folder; + FFileName := FFolder.Path + SearchRec.Name; + FName := SearchRec.Name; + for i := Length(FName) downto 1 do + if FName[i] = '.' then + begin + FExtension := Copy(FName, i + 1, Length(FName) - i); + FName := Copy(FName, 1, i - 1); + Break; + end; + FSize := SearchRec.Size; + FAttributes := AttrToJMCAttr(SearchRec.Attr); + FTime := FileDateToDateTime(SearchRec.Time); +end; + +{ TJMC_Folder } + +procedure TJMC_Folder.Clear; +var + i: Integer; +begin + FParent := nil; + FPath := ''; + FName := ''; + FAttributes := []; + FTime := 0; + FItems.Clear; + for i := 0 to FileCount - 1 do + Files[i].Free; + FFiles.Clear; + for i := 0 to ChildCount - 1 do + Children[i].Free; + FChildren.Clear; +end; + +constructor TJMC_Folder.Create(const Parent: TJMC_Folder); +begin + FParent := Parent; + if FParent <> nil then + FFileManager := FParent.FileManager; + FFiles := TList.Create; + FChildren := TList.Create; + FItems := TList.Create; +end; + +destructor TJMC_Folder.Destroy; +var + i: Integer; +begin + for i := 0 to FileCount - 1 do + Files[i].Free; + FFiles.Free; + for i := 0 to ChildCount - 1 do + Children[i].Free; + FChildren.Free; + FItems.Free; + inherited; +end; + +procedure TJMC_Folder.Fill(const SearchRec: TSearchRec); +var + F: TSearchRec; +begin + if FParent <> nil then + begin + FPath := FParent.Path + SearchRec.Name + '\'; + FName := SearchRec.Name; + FAttributes := AttrToJMCAttr(SearchRec.Attr); + FTime := FileDateToDateTime(SearchRec.Time); + end + else + begin + FName := FPath; + end; + FFileManager.CallAddFolder(Self); + FillChar(F, SizeOf(F), #0); + if FindFirst(FPath + '*', faAnyFile, F) = 0 then + try + repeat + if FFileManager.Cancelled then + Exit; + if (F.Name = '.') or (F.Name = '..') then + Continue; + if DirectoryExists(FPath + F.Name) then + begin + FChildren.Add(TJMC_Folder.Create(Self)); + FItems.Add(Children[ChildCount - 1]); + Children[ChildCount - 1].Fill(F); + end + else + begin + if FFileManager.AllowAddFile(FPath + F.Name) then + begin + FItems.Add(FFiles[FFiles.Add(TJMC_File.Create(Self, F))]); + FFileManager.CallAddFile(Files[FileCount - 1]); + end; + end; + Application.ProcessMessages; + if Application.Terminated then + Exit; + until FindNext(F) <> 0; + finally + SysUtils.FindClose(F); + end; +end; + +function TJMC_Folder.GetChild(const Index: Integer): TJMC_Folder; +begin + Result := FChildren[Index]; +end; + +function TJMC_Folder.GetChildCount: Integer; +begin + Result := FChildren.Count; +end; + +function TJMC_Folder.GetFile(const Index: Integer): TJMC_File; +begin + Result := FFiles[Index]; +end; + +function TJMC_Folder.GetFileCount: Integer; +begin + Result := FFiles.Count; +end; + +function TJMC_Folder.GetItem(const Index: Integer): TObject; +begin + Result := FItems[Index]; +end; + +function TJMC_Folder.GetItemCount: Integer; +begin + Result := FItems.Count; +end; + +function TJMC_Folder.GetItemName(const Index: Integer): string; +var + Item: TObject; +begin + Result := ''; + Item := Items[Index]; + if Item <> nil then + if Item is TJMC_Folder then + Result := TJMC_Folder(Item).Name + else + if Item is TJMC_File then + Result := TJMC_File(Item).Name; +end; + +function TJMC_Folder.ItemIndex(const Item: TObject): Integer; +var + i: Integer; +begin + for i := 0 to ItemCount - 1 do + if Items[i] <> nil then + if Items[i] = Item then + begin + Result := i; + Exit; + end; + Result := -1; +end; + +procedure TJMC_Folder.SetPath(const Value: string); +var + F: SysUtils.TSearchRec; +begin + Clear; + if DirectoryExists(Value) then + begin + FPath := IncludeTrailingPathDelimiter(Value); + FillChar(F, SizeOf(F), #0); + if SysUtils.FindFirst(Value + '*', faAnyFile, F) = 0 then + begin + Fill(F); + SysUtils.FindClose(F); + end; + end; +end; + +{ TJMC_FileManager } + +function TJMC_FileManager.AllowAddFile(const FileName: string): Boolean; +begin + Result := True; + if Assigned(FOnAllowAddFile) then + Result := FOnAllowAddFile(FileName); +end; + +procedure TJMC_FileManager.CallAddFile(const AddedFile: TJMC_File); +begin + if Assigned(FOnAddFile) then + FOnAddFile(Self, AddedFile); +end; + +procedure TJMC_FileManager.CallAddFolder(const AddedFolder: TJMC_Folder); +begin + if Assigned(FOnAddFolder) then + FOnAddFolder(Self, AddedFolder); +end; + +procedure TJMC_FileManager.Cancel; +begin + FCancelled := True; +end; + +procedure TJMC_FileManager.ClearRootFolders; +var + i: Integer; +begin + for i := 0 to RootFolderCount - 1 do + RootFolders[i].Free; + FRootFolders.Clear; +end; + +constructor TJMC_FileManager.Create; +begin + FPaths := TStringList.Create; + FRootFolders := TList.Create; +end; + +destructor TJMC_FileManager.Destroy; +var + i: Integer; +begin + for i := 0 to RootFolderCount - 1 do + RootFolders[i].Free; + FRootFolders.Free; + FPaths.Free; + inherited; +end; + +function TJMC_FileManager.GetRootFolder(const Index: Integer): TJMC_Folder; +begin + Result := FRootFolders[Index]; +end; + +function TJMC_FileManager.GetRootFolderCount: Integer; +begin + Result := FRootFolders.Count; +end; + +procedure TJMC_FileManager.Refresh; +var + i: Integer; +begin + FCancelled := False; + ClearRootFolders; + for i := 0 to FPaths.Count - 1 do + begin + FRootFolders.Add(TJMC_Folder.Create(nil)); + RootFolders[i].FileManager := Self; + RootFolders[i].Path := FPaths[i]; + end; + if Assigned(FOnFinish) then + FOnFinish(Self); +end; + +{ TJMC_TreeViewManager } + +constructor TJMC_TreeViewManager.Create(const TreeView: TTreeView); +begin + FTreeView := TreeView; + FFileManager := TJMC_FileManager.Create; +end; + +procedure TJMC_TreeViewManager.CreateTreeViewFolder(const Folder: TJMC_Folder; const Parent: TTreeNode); +var + FolderNode, FileNode: TTreeNode; + i: Integer; +begin + if Parent <> nil then + FolderNode := FTreeView.Items.AddChild(Parent, Folder.Name) + else + FolderNode := FTreeView.Items.Add(Parent, Folder.Name); + FolderNode.Data := Folder; + FolderNode.ImageIndex := JMC_ICON_FOLDERCLOSED; + FolderNode.SelectedIndex := JMC_ICON_FOLDERCLOSED; + for i := 0 to Folder.ChildCount - 1 do + CreateTreeViewFolder(Folder.Children[i], FolderNode); + for i := 0 to Folder.FileCount - 1 do + begin + Application.ProcessMessages; + if Application.Terminated then + Exit; + if Length(Folder.Files[i].Extension) > 0 then + FileNode := FTreeView.Items.AddChild(FolderNode, Folder.Files[i].Name + '.' + Folder.Files[i].Extension) + else + FileNode := FTreeView.Items.AddChild(FolderNode, Folder.Files[i].Name); + FileNode.Data := Folder.Files[i]; + FileNode.ImageIndex := JMC_ICON_FILE; + FileNode.SelectedIndex := JMC_ICON_FILE; + end; +end; + +destructor TJMC_TreeViewManager.Destroy; +begin + FFileManager.Free; + inherited; +end; + +procedure TJMC_TreeViewManager.FillTreeView; +var + i: Integer; +begin + FTreeView.Items.BeginUpdate; + FTreeView.Items.Clear; + for i := 0 to FFileManager.RootFolderCount - 1 do + CreateTreeViewFolder(FFileManager[i], nil); + FTreeView.Items.EndUpdate; +end; + +end. diff --git a/delphi/lib/JMC_FileUtils.pas b/delphi/lib/JMC_FileUtils.pas new file mode 100644 index 0000000..ea2ce77 --- /dev/null +++ b/delphi/lib/JMC_FileUtils.pas @@ -0,0 +1,116 @@ +unit JMC_FileUtils; + +interface + +uses + Classes, + ShellAPI, + SysUtils, + Windows, + FileCtrl; + +function ExpandPath(const MasterFileName, SlaveFileName: string): string; +function ExpandPathFromExe(const SlaveFileName: string): string; +function RelatePathFromExe(const SlaveFileName: string): string; +function SettingsFileName: string; +function FileToStr(const FileName: string; var S: string): Boolean; +function StrToFile(const FileName: string; var S: string): Boolean; +function CreatePath(const Path: string): Boolean; +function OpenFile(const FileName: string; const OverrideValidation: Boolean = False): Boolean; + +implementation + +{ ExpandPath doesn't work when: + MasterFileName = 'C:\My Documents\Delphi Projects\ParserFAR23\Source\Data\' + SlaveFileName = '\Data\2007-11-22 FAR 23.htm' } +function ExpandPath(const MasterFileName, SlaveFileName: string): string; // If SlaveFileName is a path only, encompass a call to ExpandPath with a call to IncludeTrailingPathDelimiter. +var + S: string; +begin + S := SysUtils.GetCurrentDir; + if not SysUtils.SetCurrentDir(ExtractFilePath(MasterFileName)) then + begin + Result := ''; + Exit; + end; + Result := SysUtils.ExpandFileName(SlaveFileName); + SysUtils.SetCurrentDir(S); +end; + +function ExpandPathFromExe(const SlaveFileName: string): string; +begin + Result := ExpandPath(SysUtils.ExtractFilePath(ParamStr(0)), SlaveFileName); +end; + +function RelatePathFromExe(const SlaveFileName: string): string; +begin + Result := SysUtils.ExtractRelativePath(SysUtils.ExtractFilePath(ParamStr(0)), SlaveFileName); +end; + +function SettingsFileName: string; +begin + Result := SysUtils.ChangeFileExt(ParamStr(0), '.ini'); +end; + +function FileToStr(const FileName: string; var S: string): Boolean; // FileName must be fully qualified +var + F: TFileStream; + Buffer: array[1..1024] of Char; + Temp: string; + i: Integer; +begin + Result := False; + S := ''; + if SysUtils.FileExists(FileName) then + try + F := Classes.TFileStream.Create(FileName, fmOpenRead + fmShareDenyNone); + F.Seek(0, soFromBeginning); + repeat + i := F.Read(Buffer, SizeOf(Buffer)); + Temp := Copy(Buffer, 1, i); + S := S + Temp; + until Length(Temp) = 0; + F.Free; + Result := True; + except + Result := False; + end; +end; + +function StrToFile(const FileName: string; var S: string): Boolean; // FileName must be fully qualified +var + F: TextFile; + Path: string; +begin + Path := ExtractFilePath(FileName); + if not FileCtrl.DirectoryExists(Path) then + FileCtrl.ForceDirectories(Path); + AssignFile(F, FileName); + try + Rewrite(F); + except + Result := False; + Exit; + end; + Write(F, S); + CloseFile(F); + Result := True; +end; + +function CreatePath(const Path: string): Boolean; +begin + try + Result := FileCtrl.ForceDirectories(Path); + except + Result := False; + end; +end; + +function OpenFile(const FileName: string; const OverrideValidation: Boolean = False): Boolean; +begin + Result := SysUtils.FileExists(FileName) or OverrideValidation; + if Result then + Result := ShellAPI.ShellExecute(0, 'open', PChar(FileName), '', nil, SW_SHOWNORMAL) <= 32; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_Graphics.pas b/delphi/lib/JMC_Graphics.pas new file mode 100644 index 0000000..ce577dc --- /dev/null +++ b/delphi/lib/JMC_Graphics.pas @@ -0,0 +1,682 @@ +unit JMC_Graphics; + +interface + +uses + Windows, + Graphics, + Types, + Controls, + Messages, + Classes, + Printers, + Math, + Dialogs, + SysUtils; + +const + MAXPIXELCOUNT = 32768; + +type + + pRGBArray = ^TRGBArray; + TRGBArray = array[0..MAXPIXELCOUNT - 1] of TRGBTriple; + +procedure GradientFill_Vert(const Buffer: Graphics.TBitmap; const TopColor, BottomColor: TColor); +procedure GradientFill_Horz(const Buffer: Graphics.TBitmap; const LeftColor, RightColor: TColor); +function NegateColor(const Value: TColor): TColor; +procedure NegateBitmap(const Value: Graphics.TBitmap); +procedure PointBox(const Canvas: TCanvas; const X, Y: Integer; const BoxSize: Integer = 5); +procedure AngleTextOut(const Canvas: TCanvas; const Text: string; X, Y, Angle: Integer); +procedure RotateBitmap(const Bitmap: Graphics.TBitmap; const AngleDegrees: Double); +procedure PrintAngleTextOut(const Text: string; X, Y, Angle: Integer); +procedure Rotate(var X, Y: Double; const Angle: Double); +procedure DrawArrowLine(const Canvas: TCanvas; const Count, X1, Y1, X2, Y2, ArrowLength, HeadLength, HeadWidth: Integer); +procedure DrawArrow(const Canvas: TCanvas; const X1, Y1, X2, Y2, ArrowLength, HeadLength, HeadWidth: Integer); + +implementation + +// Color := Windows.RGB(0, 87, 36); + +procedure GradientFill_Vert(const Buffer: Graphics.TBitmap; const TopColor, BottomColor: TColor); +var + y: Integer; + dR, dG, dB: Double; + R, G, B: Byte; +begin + with Buffer do + begin + dR := (GetRValue(BottomColor) - GetRValue(TopColor)) / Height; + dG := (GetGValue(BottomColor) - GetGValue(TopColor)) / Height; + dB := (GetBValue(BottomColor) - GetBValue(TopColor)) / Height; + with Canvas do + begin + Pen.Color := TopColor; + for y := 0 to Height do + begin + R := Round(GetRValue(TopColor) + y * dR); + G := Round(GetGValue(TopColor) + y * dG); + B := Round(GetBValue(TopColor) + y * dB); + Pen.Color := RGB(R, G, B); + MoveTo(0, y); + LineTo(Width, y); + end; + end; + end; +end; + +procedure GradientFill_Horz(const Buffer: Graphics.TBitmap; const LeftColor, RightColor: TColor); +var + x: Integer; + dR, dG, dB: Double; + R, G, B: Byte; +begin + with Buffer do + begin + dR := (GetRValue(RightColor) - GetRValue(LeftColor)) / Width; + dG := (GetGValue(RightColor) - GetGValue(LeftColor)) / Width; + dB := (GetBValue(RightColor) - GetBValue(LeftColor)) / Width; + with Canvas do + begin + Pen.Color := LeftColor; + for x := 0 to Width do + begin + R := Round(GetRValue(LeftColor) + x * dR); + G := Round(GetGValue(LeftColor) + x * dG); + B := Round(GetBValue(LeftColor) + x * dB); + Pen.Color := RGB(R, G, B); + MoveTo(x, 0); + LineTo(x, Height); + end; + end; + end; +end; + +function NegateColor(const Value: TColor): TColor; +begin + Result := RGB(255 - GetRValue(Value), 255 - GetGValue(Value), 255 - GetBValue(Value)); +end; + +procedure NegateBitmap(const Value: Graphics.TBitmap); +begin + //Value.PixelFormat := pf24bit; + InvertRect(Value.Canvas.Handle, Types.Rect(0, 0, Value.Width, Value.Height)); +end; + +procedure PointBox(const Canvas: TCanvas; const X, Y: Integer; const BoxSize: Integer = 5); +var + i: Integer; + OriginalPenWidth: Integer; +begin + if BoxSize < 3 then + Exit; + i := (BoxSize - 1) div 2; + with Canvas do + begin + OriginalPenWidth := Pen.Width; + Pen.Width := 1; + MoveTo(X - i, Y - i); + LineTo(X + i, Y - i); + MoveTo(X + i, Y - i); + LineTo(X + i, Y + i); + MoveTo(X + i, Y + i); + LineTo(X - i, Y + i); + MoveTo(X - i, Y + i); + LineTo(X - i, Y - i); + Pixels[X, Y] := Pen.Color; + Pen.Width := OriginalPenWidth; + MoveTo(X, Y); + end; +end; + +procedure RotateBitmap(const Bitmap: Graphics.TBitmap; const AngleDegrees: Double); +// http://www.efg2.com/Lab/ImageProcessing/RotateScanline.htm +var + Buffer: Graphics.TBitmap; + CosTheta: Double; + i: Integer; + iRotationAxis: Integer; + iOriginal: Integer; + iPrime: Integer; + iPrimeRotated: Integer; + j: Integer; + jRotationAxis: Integer; + jOriginal: Integer; + jPrime: Integer; + jPrimeRotated: Integer; + RowOriginal: pRGBArray; + RowRotated: pRGBArray; + SinTheta: Double; + Theta: Double; +begin + Buffer := Graphics.TBitmap.Create; + try + Buffer.Width := Bitmap.Width; + Buffer.Height := Bitmap.Height; + Buffer.PixelFormat := pf24bit; + Theta := AngleDegrees * Pi / 180; + SinTheta := Sin(Theta); + CosTheta := Cos(Theta); + iRotationAxis := Buffer.Width div 2; + jRotationAxis := Buffer.Height div 2; + for j := Buffer.Height - 1 DownTo 0 Do + begin + RowRotated := Buffer.ScanLine[j]; + jPrime := 2 * (j - jRotationAxis) + 1; + for i := Buffer.Width - 1 DownTo 0 Do + begin + iPrime := 2 * (i - iRotationAxis) + 1; + iPrimeRotated := Round(iPrime * CosTheta - jPrime * SinTheta); + jPrimeRotated := Round(iPrime * SinTheta + jPrime * CosTheta); + iOriginal := (iPrimeRotated - 1) div 2 + iRotationAxis; + jOriginal := (jPrimeRotated - 1) div 2 + jRotationAxis; + if (iOriginal >= 0) and (iOriginal <= Bitmap.Width - 1) and (jOriginal >= 0) and (jOriginal <= Bitmap.Height - 1) then + begin + RowOriginal := Bitmap.ScanLine[jOriginal]; + RowRotated[i] := RowOriginal[iOriginal]; + end + else + begin + RowRotated[i].rgbtBlue := 255; + RowRotated[i].rgbtGreen := 0; + RowRotated[i].rgbtRed := 0; + end; + end; + end; + Bitmap.Assign(Buffer); + finally + Buffer.Free; + end; +end; + +procedure PrintAngleTextOut(const Text: string; X, Y, Angle: Integer); +// http://www.efg2.com/Lab/Library/Delphi/Printing/JoeHechtRotatedFontOnPrinter.TXT (26 September 2008) +var + LogFont: Windows.TLogFont; + OldFont: Windows.HFONT; + NewFont: Windows.HFONT; +begin + Printer.Canvas.Font.PixelsPerInch := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY); + GetObject(Printer.Canvas.Font.Handle, SizeOf(LogFont), @LogFont); + LogFont.lfEscapement := Angle * 10; + LogFont.lfOrientation := Angle * 10; + NewFont := CreateFontIndirect(LogFont); + OldFont := SelectObject(Printer.Canvas.Handle, NewFont); + Windows.TextOut(Printer.Canvas.Handle, X, Y, PChar(Text), Length(Text)); + SelectObject(Printer.Canvas.Handle, OldFont); + DeleteObject(NewFont); +end; + +procedure AngleTextOut(const Canvas: TCanvas; const Text: string; X, Y, Angle: Integer); +// http://www.efg2.com/Lab/Library/Delphi/Printing/JoeHechtRotatedFontOnPrinter.TXT (26 September 2008) +var + LogFont: Windows.TLogFont; + OldFont: Windows.HFONT; + NewFont: Windows.HFONT; +begin + Canvas.Font.PixelsPerInch := GetDeviceCaps(Canvas.Handle, LOGPIXELSY); + GetObject(Canvas.Font.Handle, SizeOf(LogFont), @LogFont); + LogFont.lfEscapement := Angle * 10; + LogFont.lfOrientation := Angle * 10; + NewFont := CreateFontIndirect(LogFont); + OldFont := SelectObject(Canvas.Handle, NewFont); + Windows.TextOut(Canvas.Handle, X, Y, PChar(Text), Length(Text)); + SelectObject(Canvas.Handle, OldFont); + DeleteObject(NewFont); +end; + +procedure Rotate(var X, Y: Double; const Angle: Double); +var + T: Double; + x1: Double; + y1: Double; +begin + T := Angle * Pi / 180; + x1 := X * Cos(T) - Y * Sin(T); + y1 := X * Sin(T) + Y * Cos(T); + X := x1; + Y := y1; +end; + +procedure DrawArrowLine(const Canvas: TCanvas; const Count, X1, Y1, X2, Y2, ArrowLength, HeadLength, HeadWidth: Integer); +var + L: Double; + Gap: Double; + i: Integer; + X: Double; + Y: Double; + Angle: Double; + dx, dy: Double; + xx, yy: Double; + xx1, yy1: Double; +begin + // Point 1 to Point 2 (Head of Arrow @ Point 2) + L := Sqrt(Sqr(X2 - X1) + Sqr(Y2 - Y1)); + Gap := (L - Count * ArrowLength) / (Count - 1); + if X1 <> X2 then + begin + if X1 > X2 then + begin + if Y1 <> Y2 then + begin + if Y1 > Y2 then + begin + // X1 > X2, Y1 > Y2 (Points TOP LEFT) + dx := X1 - X2; + dy := Y1 - Y2; + Angle := ArcTan(dy / dx); + X := X1; + Y := Y1; + for i := 1 to Count do + begin + Canvas.MoveTo(Round(X), Round(Y)); + X := X - ArrowLength * Cos(Angle); + Y := Y - ArrowLength * Sin(Angle); + Canvas.LineTo(Round(X), Round(Y)); + xx1 := HeadLength; + yy1 := -HeadWidth div 2; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + xx1 := HeadLength; + yy1 := HeadWidth div 2; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.MoveTo(Round(X), Round(Y)); + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + X := X - Gap * Cos(Angle); + Y := Y - Gap * Sin(Angle); + end; + end + else + begin + // X1 > X2, Y1 < Y2 (Points BOTTOM LEFT) + dx := X1 - X2; + dy := Y2 - Y1; + Angle := ArcTan(dx / dy); + X := X1; + Y := Y1; + for i := 1 to Count do + begin + Canvas.MoveTo(Round(X), Round(Y)); + X := X - ArrowLength * Sin(Angle); + Y := Y + ArrowLength * Cos(Angle); + Canvas.LineTo(Round(X), Round(Y)); + xx1 := -HeadWidth div 2; + yy1 := HeadLength; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + xx1 := HeadWidth div 2; + yy1 := HeadLength; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.MoveTo(Round(X), Round(Y)); + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + X := X - Gap * Sin(Angle); + Y := Y + Gap * Cos(Angle); + end; + end; + end + else + begin + // X1 > X2, Y1 = Y2 (Points LEFT) + X := X1; + for i := 1 to Count do + begin + Canvas.MoveTo(Round(X), Y1); + X := X - ArrowLength; + Canvas.LineTo(Round(X), Y1); + Canvas.MoveTo(Round(X), Y1); + Canvas.LineTo(Round(X) + HeadLength, Y1 + HeadWidth div 2); + Canvas.MoveTo(Round(X), Y1); + Canvas.LineTo(Round(X) + HeadLength, Y1 - HeadWidth div 2); + X := X - Gap; + end; + end; + end + else + begin + // X1 < X2 + if Y1 <> Y2 then + begin + if Y1 > Y2 then + begin + // X1 < X2, Y1 > Y2 (Points TOP RIGHT) + dx := X2 - X1; + dy := Y1 - Y2; + Angle := ArcTan(dx / dy); + X := X1; + Y := Y1; + for i := 1 to Count do + begin + Canvas.MoveTo(Round(X), Round(Y)); + X := X + ArrowLength * Sin(Angle); + Y := Y - ArrowLength * Cos(Angle); + Canvas.LineTo(Round(X), Round(Y)); + xx1 := -HeadWidth div 2; + yy1 := -HeadLength; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + xx1 := HeadWidth div 2; + yy1 := -HeadLength; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.MoveTo(Round(X), Round(Y)); + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + X := X + Gap * Sin(Angle); + Y := Y - Gap * Cos(Angle); + end; + end + else + begin + // X1 < X2, Y1 < Y2 (Points BOTTOM RIGHT) + dx := X2 - X1; + dy := Y2 - Y1; + Angle := ArcTan(dy / dx); + X := X1; + Y := Y1; + for i := 1 to Count do + begin + Canvas.MoveTo(Round(X), Round(Y)); + X := X + ArrowLength * Cos(Angle); + Y := Y + ArrowLength * Sin(Angle); + Canvas.LineTo(Round(X), Round(Y)); + xx1 := -HeadLength; + yy1 := -HeadWidth div 2; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + xx1 := -HeadLength; + yy1 := HeadWidth div 2; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.MoveTo(Round(X), Round(Y)); + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + X := X + Gap * Cos(Angle); + Y := Y + Gap * Sin(Angle); + end; + end; + end + else + begin + // X1 < X2, Y1 = Y2 (Points RIGHT) + X := X1; + for i := 1 to Count do + begin + Canvas.MoveTo(Round(X), Y1); + X := X + ArrowLength; + Canvas.LineTo(Round(X), Y1); + Canvas.MoveTo(Round(X), Y1); + Canvas.LineTo(Round(X) - HeadLength, Y1 + HeadWidth div 2); + Canvas.MoveTo(Round(X), Y1); + Canvas.LineTo(Round(X) - HeadLength, Y1 - HeadWidth div 2); + X := X + Gap; + end; + end; + end; + end + else + begin + // X1 = X2 + if Y1 <> Y2 then + begin + if Y1 > Y2 then + begin + // X1 = X2, Y1 > Y2 (Points UP) + Y := Y1; + for i := 1 to Count do + begin + Canvas.MoveTo(X1, Round(Y)); + Y := Y - ArrowLength; + Canvas.LineTo(X1, Round(Y)); + Canvas.MoveTo(X1, Round(Y)); + Canvas.LineTo(X1 + HeadWidth div 2, Round(Y) + HeadLength); + Canvas.MoveTo(X1, Round(Y)); + Canvas.LineTo(X1 - HeadWidth div 2, Round(Y) + HeadLength); + Y := Y - Gap; + end; + end + else + begin + // X1 = X2, Y1 < Y2 (Points DOWN) + Y := Y1; + for i := 1 to Count do + begin + Canvas.MoveTo(X1, Round(Y)); + Y := Y + ArrowLength; + Canvas.LineTo(X1, Round(Y)); + Canvas.MoveTo(X1, Round(Y)); + Canvas.LineTo(X1 + HeadWidth div 2, Round(Y) - HeadLength); + Canvas.MoveTo(X1, Round(Y)); + Canvas.LineTo(X1 - HeadWidth div 2, Round(Y) - HeadLength); + Y := Y + Gap; + end; + end; + end + else + begin + // X1 = X2, Y1 = Y2 + Exit; + end; + end; +end; + +procedure DrawArrow(const Canvas: TCanvas; const X1, Y1, X2, Y2, ArrowLength, HeadLength, HeadWidth: Integer); +var + X: Double; + Y: Double; + Angle: Double; + dx, dy: Double; + xx, yy: Double; + xx1, yy1: Double; +begin + // Point 1 to Point 2 (Head of Arrow @ Point 2) + if X1 <> X2 then + begin + if X1 > X2 then + begin + if Y1 <> Y2 then + begin + if Y1 > Y2 then + begin + // X1 > X2, Y1 > Y2 (Points TOP LEFT) + dx := X1 - X2; + dy := Y1 - Y2; + Angle := ArcTan(dy / dx); + X := X1; + Y := Y1; + Canvas.MoveTo(Round(X), Round(Y)); + X := X - ArrowLength * Cos(Angle); + Y := Y - ArrowLength * Sin(Angle); + Canvas.LineTo(Round(X), Round(Y)); + xx1 := HeadLength; + yy1 := -HeadWidth div 2; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + xx1 := HeadLength; + yy1 := HeadWidth div 2; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.MoveTo(Round(X), Round(Y)); + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + end + else + begin + // X1 > X2, Y1 < Y2 (Points BOTTOM LEFT) + dx := X1 - X2; + dy := Y2 - Y1; + Angle := ArcTan(dx / dy); + X := X1; + Y := Y1; + Canvas.MoveTo(Round(X), Round(Y)); + X := X - ArrowLength * Sin(Angle); + Y := Y + ArrowLength * Cos(Angle); + Canvas.LineTo(Round(X), Round(Y)); + xx1 := -HeadWidth div 2; + yy1 := HeadLength; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + xx1 := HeadWidth div 2; + yy1 := HeadLength; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.MoveTo(Round(X), Round(Y)); + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + end; + end + else + begin + // X1 > X2, Y1 = Y2 (Points LEFT) + X := X1; + Canvas.MoveTo(Round(X), Y1); + X := X - ArrowLength; + Canvas.LineTo(Round(X), Y1); + Canvas.MoveTo(Round(X), Y1); + Canvas.LineTo(Round(X) + HeadLength, Y1 + HeadWidth div 2); + Canvas.MoveTo(Round(X), Y1); + Canvas.LineTo(Round(X) + HeadLength, Y1 - HeadWidth div 2); + end; + end + else + begin + // X1 < X2 + if Y1 <> Y2 then + begin + if Y1 > Y2 then + begin + // X1 < X2, Y1 > Y2 (Points TOP RIGHT) + dx := X2 - X1; + dy := Y1 - Y2; + Angle := ArcTan(dx / dy); + X := X1; + Y := Y1; + Canvas.MoveTo(Round(X), Round(Y)); + X := X + ArrowLength * Sin(Angle); + Y := Y - ArrowLength * Cos(Angle); + Canvas.LineTo(Round(X), Round(Y)); + xx1 := -HeadWidth div 2; + yy1 := -HeadLength; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + xx1 := HeadWidth div 2; + yy1 := -HeadLength; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.MoveTo(Round(X), Round(Y)); + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + end + else + begin + // X1 < X2, Y1 < Y2 (Points BOTTOM RIGHT) + dx := X2 - X1; + dy := Y2 - Y1; + Angle := ArcTan(dy / dx); + X := X1; + Y := Y1; + Canvas.MoveTo(Round(X), Round(Y)); + X := X + ArrowLength * Cos(Angle); + Y := Y + ArrowLength * Sin(Angle); + Canvas.LineTo(Round(X), Round(Y)); + xx1 := -HeadLength; + yy1 := -HeadWidth div 2; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + xx1 := -HeadLength; + yy1 := HeadWidth div 2; + xx := xx1 * Cos(Angle) + yy1 * Sin(Angle); + yy := -xx1 * Sin(Angle) + yy1 * Cos(Angle); + xx1 := xx; + yy1 := -yy; + Canvas.MoveTo(Round(X), Round(Y)); + Canvas.LineTo(Round(X + xx1), Round(Y + yy1)); + end; + end + else + begin + // X1 < X2, Y1 = Y2 (Points RIGHT) + X := X1; + Canvas.MoveTo(Round(X), Y1); + X := X + ArrowLength; + Canvas.LineTo(Round(X), Y1); + Canvas.MoveTo(Round(X), Y1); + Canvas.LineTo(Round(X) - HeadLength, Y1 + HeadWidth div 2); + Canvas.MoveTo(Round(X), Y1); + Canvas.LineTo(Round(X) - HeadLength, Y1 - HeadWidth div 2); + end; + end; + end + else + begin + // X1 = X2 + if Y1 <> Y2 then + begin + if Y1 > Y2 then + begin + // X1 = X2, Y1 > Y2 (Points UP) + Y := Y1; + Canvas.MoveTo(X1, Round(Y)); + Y := Y - ArrowLength; + Canvas.LineTo(X1, Round(Y)); + Canvas.MoveTo(X1, Round(Y)); + Canvas.LineTo(X1 + HeadWidth div 2, Round(Y) + HeadLength); + Canvas.MoveTo(X1, Round(Y)); + Canvas.LineTo(X1 - HeadWidth div 2, Round(Y) + HeadLength); + end + else + begin + // X1 = X2, Y1 < Y2 (Points DOWN) + Y := Y1; + Canvas.MoveTo(X1, Round(Y)); + Y := Y + ArrowLength; + Canvas.LineTo(X1, Round(Y)); + Canvas.MoveTo(X1, Round(Y)); + Canvas.LineTo(X1 + HeadWidth div 2, Round(Y) - HeadLength); + Canvas.MoveTo(X1, Round(Y)); + Canvas.LineTo(X1 - HeadWidth div 2, Round(Y) - HeadLength); + end; + end + else + begin + // X1 = X2, Y1 = Y2 + Exit; + end; + end; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_HTTP_NonBlocking.pas b/delphi/lib/JMC_HTTP_NonBlocking.pas new file mode 100644 index 0000000..b1a9e26 --- /dev/null +++ b/delphi/lib/JMC_HTTP_NonBlocking.pas @@ -0,0 +1,573 @@ +unit JMC_HTTP_NonBlocking; + +interface + +uses + Classes, + Controls, + StdCtrls, + SysUtils, + ExtCtrls, + Forms, + Dialogs, + Sockets, + WinInet, + Windows, + ScktComp, + ComCtrls, + JMC_Parts; + +type + + TJMC_HTTP_Request = class; + + TJMC_HTTP_RequestType = (JMC_HTTP_rtGet, JMC_HTTP_rtPost, JMC_HTTP_rtMultipart); + + TJMC_HTTP_Parameter = class(TObject) + private + FKey: string; + FValue: string; + FRequest: TJMC_HTTP_Request; + public + constructor Create(const Request: TJMC_HTTP_Request); + public + function AsFormatted: string; + procedure SetParameter(const Key: string; const Value: string); + public + property Key: string read FKey write FKey; + property Value: string read FValue write FValue; + end; + + TJMC_HTTP_ParameterArray = class(TObject) + private + FParameters: TList; + FRequest: TJMC_HTTP_Request; + private + function GetCount: Integer; + function GetParameter(const Index: Integer): TJMC_HTTP_Parameter; + public + constructor Create(const Request: TJMC_HTTP_Request); + destructor Destroy; override; + public + function Add: TJMC_HTTP_Parameter; + procedure Clear; + public + property Count: Integer read GetCount; + property Parameters[const Index: Integer]: TJMC_HTTP_Parameter read GetParameter; default; + end; + + TJMC_HTTP_Request = class(TObject) + private + FHost: string; + FPort: Integer; + FRequest: string; + FUserAgent: string; + private + FReadCount: Integer; + FReadStatus: string; + private + FConnected: Boolean; + private + FRequestType: TJMC_HTTP_RequestType; + FMultipartBoundary: string; + private + FResponseContent: string; + FResponseHeaders: string; + private + FPingStart: Cardinal; + FPingEnd: Cardinal; + private + FOnConnect: TNotifyEvent; + FOnConnecting: TNotifyEvent; + FOnDisconnect: TNotifyEvent; + FOnError: TNotifyEvent; + private + FLabelDownloadSize: TLabel; + FLabelPingTime: TLabel; + FLabelPingTimerInterval: TLabel; + FLabelStatus: TLabel; + FMemoReadStatus: TMemo; + FMemoRequest: TMemo; + FMemoResponseContent: TMemo; + FMemoResponseHeaders: TMemo; + FPanelProgressParent: TPanel; + FShapeProgressBar: TShape; + FTimerPing: TTimer; + private + FParameters: TJMC_HTTP_ParameterArray; + private + FClientSocket: TClientSocket; + private + procedure DoError; + private + procedure ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket); + procedure ClientSocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer); + procedure ClientSocketConnect(Sender: TObject; Socket: TCustomWinSocket); + procedure ClientSocketConnecting(Sender: TObject; Socket: TCustomWinSocket); + procedure ClientSocketDisconnect(Sender: TObject; Socket: TCustomWinSocket); + public + constructor Create; + destructor Destroy; override; + public + procedure AddParameter(const Key: string; const Value: string); + procedure Clear; + public + procedure SendRequest(const ServerAddress: string); + public + property OnConnect: TNotifyEvent read FOnConnect write FOnConnect; + property OnConnecting: TNotifyEvent read FOnConnecting write FOnConnecting; + property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect; + property OnError: TNotifyEvent read FOnError write FOnError; + public + property ClientSocket: TClientSocket read FClientSocket; + public + property Connected: Boolean read FConnected; + public + property RequestType: TJMC_HTTP_RequestType read FRequestType write FRequestType; + property MultipartBoundary: string read FMultipartBoundary write FMultipartBoundary; + property UserAgent: string read FUserAgent write FUserAgent; + public + property LabelDownloadSize: TLabel read FLabelDownloadSize write FLabelDownloadSize; + property LabelPingTime: TLabel read FLabelPingTime write FLabelPingTime; + property LabelPingTimerInterval: TLabel read FLabelPingTimerInterval write FLabelPingTimerInterval; + property LabelStatus: TLabel read FLabelStatus write FLabelStatus; + property MemoReadStatus: TMemo read FMemoReadStatus write FMemoReadStatus; + property MemoRequest: TMemo read FMemoRequest write FMemoRequest; + property MemoResponseContent: TMemo read FMemoResponseContent write FMemoResponseContent; + property MemoResponseHeaders: TMemo read FMemoResponseHeaders write FMemoResponseHeaders; + property PanelProgressParent: TPanel read FPanelProgressParent write FPanelProgressParent; + property ShapeProgressBar: TShape read FShapeProgressBar write FShapeProgressBar; + property TimerPing: TTimer read FTimerPing write FTimerPing; + end; + +procedure ParseAddress(const Address: string; var Port: Integer; var Host: string; var Request: string); + +implementation + +function IsNumbersOnly(const Value: string): Boolean; +var + i: Integer; +begin + if Length(Value) = 0 then + begin + Result := False; + Exit; + end; + Result := True; + for i := 1 to Length(Value) do + case Ord(Value[i]) of + 48..57: Continue; + else + Result := False; + Exit; + end; +end; + +procedure ParseAddress(const Address: string; var Port: Integer; var Host: string; var Request: string); +var + i: Integer; + j: Integer; + S: string; + p1: string; + p2: string; +begin + S := Address; + i := Pos('//', S); + p1 := ''; + if i > 0 then + begin + p1 := LowerCase(Copy(S, 1, i - 1)); + p2 := ''; + for j := 1 to Length(p1) do + case p1[j] of + 'a'..'z': p2 := p2 + p1[j]; + else + Break; + end; + if p2 = 'http' then + p1 := '80' + else + if p2 = 'https' then + p1 := '443' + else + p1 := ''; + S := Copy(S, i + 2, Length(S) - i - 1); + end; + i := Pos('/', S); + if i <= 0 then + begin + S := S + '/'; + i := Length(S); + end; + Host := Copy(S, 1, i - 1); + Request := Copy(S, i, Length(S) - i + 1); + i := Pos(':', Request); + if i > 0 then + begin + p1 := Copy(Request, i + 1, Length(Request) - i); + if IsNumbersOnly(p1) then + Request := Copy(Request, 1, i - 1) + else + p1 := ''; + end; + if Length(p1) = 0 then + p1 := '80'; + try + Port := StrToInt(p1); + except + Port := 80; + end; +end; + +function HexToInt(const HexNum: string): Integer; +begin + Result := StrToInt('$' + HexNum); +end; + +function EncodeParameter(const Key: string; const Value: string; const Request: TJMC_HTTP_Request): string; +var + i: Integer; + S: Classes.TStrings; +begin + if Request.RequestType = JMC_HTTP_rtMultipart then + begin + Result := '--' + Request.MultipartBoundary + #13#10; + if SysUtils.FileExists(Value) = False then + Result := Result + 'Content-Disposition: form-data; name="nonfile_field"' + #13#10#13#10 + Value + else + begin + S := Classes.TStringList.Create; + try + S.LoadFromFile(Value); + except + end; + Result := Result + 'Content-Disposition: form-data; name="' + Key + '"; filename="' + SysUtils.ExtractFileName(Value) + '"' + #13#10 + 'Content-Type: text/plain' + #13#10#13#10 + S.Text; + S.Free; + end; + end + else + begin + Result := Key + '='; + for i := 1 to Length(Value) do + Result := Result + '%' + IntToHex(Ord(Value[i]), 2); + end; +end; + +function DecodeParameter(const Key: string; const Value: string; const Request: TJMC_HTTP_Request): string; +var + i: Integer; + S: string; +begin + if Request.RequestType = JMC_HTTP_rtMultipart then + begin + Result := ''; + end + else + begin + i := Length(Key + '=') + 1; + Result := ''; + repeat + S := Copy(Value, i + 1, 2); + Result := Result + Chr(HexToInt(S)); + Inc(i, 3); + until i >= Length(Value); + end; +end; + +{ TJMC_HTTP_Parameter } + +function TJMC_HTTP_Parameter.AsFormatted: string; +begin + Result := EncodeParameter(FKey, FValue, FRequest); +end; + +constructor TJMC_HTTP_Parameter.Create(const Request: TJMC_HTTP_Request); +begin + FRequest := Request; +end; + +procedure TJMC_HTTP_Parameter.SetParameter(const Key, Value: string); +begin + FKey := Key; + FValue := Value; +end; + +{ TJMC_HTTP_ParameterArray } + +function TJMC_HTTP_ParameterArray.Add: TJMC_HTTP_Parameter; +begin + Result := TJMC_HTTP_Parameter.Create(FRequest); + FParameters.Add(Result); +end; + +procedure TJMC_HTTP_ParameterArray.Clear; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Parameters[i].Free; + FParameters.Clear; +end; + +constructor TJMC_HTTP_ParameterArray.Create(const Request: TJMC_HTTP_Request); +begin + FRequest := Request; + FParameters := TList.Create; +end; + +destructor TJMC_HTTP_ParameterArray.Destroy; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Parameters[i].Free; + FParameters.Free; + inherited; +end; + +function TJMC_HTTP_ParameterArray.GetCount: Integer; +begin + Result := FParameters.Count; +end; + +function TJMC_HTTP_ParameterArray.GetParameter(const Index: Integer): TJMC_HTTP_Parameter; +begin + Result := FParameters[Index]; +end; + +{ TJMC_HTTP_Request } + +procedure TJMC_HTTP_Request.AddParameter(const Key, Value: string); +begin + FParameters.Add.SetParameter(Key, Value); +end; + +procedure TJMC_HTTP_Request.Clear; +begin + FHost := ''; + FPort := 0; + FRequest := ''; + FReadCount := 0; + FReadStatus := ''; + FResponseContent := ''; + FResponseHeaders := ''; + FPingStart := 0; + FPingEnd := 0; + FParameters.Clear; +end; + +procedure TJMC_HTTP_Request.ClientSocketConnect(Sender: TObject; Socket: TCustomWinSocket); +var + RequestContent: string; + UserAgentHeader: string; + S: string; + i: Integer; +begin + FConnected := True; + if Assigned(FMemoResponseContent) then + FMemoResponseContent.Clear; + if Assigned(FMemoResponseHeaders) then + FMemoResponseHeaders.Clear; + FReadCount := 0; + FResponseContent := ''; + FReadStatus := ''; + if Assigned(FShapeProgressBar) and Assigned(FPanelProgressParent) then + begin + FShapeProgressBar.Align := alNone; + FShapeProgressBar.Left := -FShapeProgressBar.Width; + end; + if Assigned(FLabelPingTime) then + FLabelPingTime.Caption := 'Ping:'; + if Assigned(FLabelStatus) then + FLabelStatus.Caption := 'SENDING REQUEST...'; + RequestContent := ''; + for i := 0 to FParameters.Count - 1 do + if Length(RequestContent) > 0 then + begin + if FRequestType = JMC_HTTP_rtMultipart then + RequestContent := RequestContent + #13#10 + FParameters[i].AsFormatted + else + RequestContent := RequestContent + '&' + FParameters[i].AsFormatted; + end + else + RequestContent := FParameters[i].AsFormatted; + // Use web-sniffer.net to develop request + FUserAgent := Trim(FUserAgent); + if Length(FUserAgent) > 0 then + UserAgentHeader := 'User-Agent: ' + FUserAgent + #13#10 + else + UserAgentHeader := ''; + S := ''; + case FRequestType of + JMC_HTTP_rtGet: + if Length(RequestContent) > 0 then + S := 'GET ' + FRequest + '?' + RequestContent + ' HTTP/1.1' + #13#10 + 'Host: ' + FHost + #13#10 + UserAgentHeader + 'Connection: close' + #13#10#13#10 + else + S := 'GET ' + FRequest + ' HTTP/1.1' + #13#10 + 'Host: ' + FHost + #13#10 + UserAgentHeader + 'Connection: close' + #13#10#13#10; + JMC_HTTP_rtPost: + S := 'POST ' + FRequest + ' HTTP/1.1' + #13#10 + 'Host: ' + FHost + #13#10 + UserAgentHeader + 'Content-Type: application/x-www-form-urlencoded' + #13#10 + 'Content-Length: ' + IntToStr(Length(RequestContent)) + #13#10 + 'Connection: close' + #13#10 + 'Accept: text/*' + #13#10#13#10 + RequestContent; + JMC_HTTP_rtMultipart: + S := 'POST ' + FRequest + ' HTTP/1.1' + #13#10 + 'Host: ' + FHost + #13#10 + UserAgentHeader + 'Content-Type: multipart/form-data; boundary=' + FMultipartBoundary + #13#10 + 'Content-Length: ' + IntToStr(Length(RequestContent)) + #13#10 + 'Connection: close' + #13#10 + 'Accept: text/*' + #13#10#13#10 + RequestContent; + end; + if Assigned(FMemoRequest) then + FMemoRequest.Lines.Text := S; + FParameters.Clear; + try + Socket.SendText(S); + except + DoError; + end; + if Assigned(FOnConnect) then + FOnConnect(Self); +end; + +procedure TJMC_HTTP_Request.ClientSocketConnecting(Sender: TObject; Socket: TCustomWinSocket); +begin + if Assigned(FLabelStatus) then + FLabelStatus.Caption := 'SOCKET CONNECTING...'; + if Assigned(FOnConnecting) then + FOnConnecting(Self); +end; + +procedure TJMC_HTTP_Request.ClientSocketDisconnect(Sender: TObject; Socket: TCustomWinSocket); +var + PingDelta: Cardinal; +begin + if not Application.Terminated then + ClientSocketRead(Sender, Socket); + if Assigned(FMemoResponseContent) then + FMemoResponseContent.Lines.Text := FResponseContent; + if Assigned(FMemoReadStatus) then + FMemoReadStatus.Lines.Text := FReadStatus; + if Assigned(FMemoResponseHeaders) then + FMemoResponseHeaders.Lines.Text := FResponseHeaders; + FPingEnd := GetTickCount; + PingDelta := FPingEnd - FPingStart; + if Assigned(FLabelPingTime) then + FLabelPingTime.Caption := 'Ping: ' + IntToStr(PingDelta) + ' milliseconds'; + if Assigned(FTimerPing) then + if FTimerPing.Interval < (PingDelta + 500) then + begin + FTimerPing.Enabled := False; + FTimerPing.Interval := PingDelta + 500; + FTimerPing.Enabled := True; + end; + if Assigned(FLabelPingTimerInterval) and Assigned(FTimerPing) then + FLabelPingTimerInterval.Caption := 'Timer Interval: ' + IntToStr(FTimerPing.Interval) + ' milliseconds'; + if Assigned(FShapeProgressBar) and Assigned(FPanelProgressParent) then + FShapeProgressBar.Left := -FShapeProgressBar.Width; + if Assigned(FLabelStatus) then + if Length(FResponseHeaders) > 0 then + FLabelStatus.Caption := 'SOCKET DISCONNECTED: RESPONSE RECEIVED' + else + FLabelStatus.Caption := 'SOCKET DISCONNECTED: NO RESPONSE'; + Application.ProcessMessages; + FConnected := False; + if Assigned(FOnDisconnect) then + FOnDisconnect(Self); +end; + +procedure TJMC_HTTP_Request.ClientSocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer); +begin + ErrorCode := 0; + DoError; +end; + +procedure TJMC_HTTP_Request.ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket); +var + L: Integer; + //Buf: array[0..1023] of Char; + Buf: array[0..4096] of Char; // REQUIRED FOR CHUNKED ENCODING POST RESPONSES (OTHERWISE RESPONSE IS INCOMPLETE) + n: Integer; + i: Integer; +begin + Application.ProcessMessages; + if Application.Terminated then + begin + Socket.Close; + Exit; + end; + FillChar(Buf, SizeOf(Buf), #0); + L := SizeOf(Buf); + n := Socket.ReceiveBuf(Buf, L); + FResponseContent := SysUtils.TrimRight(FResponseContent + Buf); + if Assigned(FLabelDownloadSize) then + FLabelDownloadSize.Caption := 'Downloaded: ' + IntToStr(Length(FResponseContent)) + ' bytes (' + Format('%.1f', [Length(FResponseContent) / 1024]) + ' kb)'; + i := Pos(#13#10#13#10, FResponseContent); + if (i > 0) and (Length(FResponseHeaders) = 0) then + begin + FResponseHeaders := Copy(FResponseContent, 1, i - 1); + FResponseContent := Copy(FResponseContent, i + Length(#13#10#13#10), Length(FResponseContent) - i - Length(#13#10#13#10) + 1); + end; + FReadCount := FReadCount + 1; + if Assigned(FLabelStatus) then + FLabelStatus.Caption := 'SOCKET READING (COUNT: ' + SysUtils.IntToStr(FReadCount) + ')'; + if FReadStatus <> '' then + FReadStatus := FReadStatus + #13#10; + FReadStatus := FReadStatus + '#' + IntToStr(FReadCount) + ': ' + IntToStr(L) + '~' + IntToStr(n); + if Assigned(FShapeProgressBar) and Assigned(FPanelProgressParent) then + begin + if FShapeProgressBar.Left >= FPanelProgressParent.ClientWidth then + FShapeProgressBar.Left := -FShapeProgressBar.Width; + FShapeProgressBar.Left := FShapeProgressBar.Left + 1; + end; +end; + +constructor TJMC_HTTP_Request.Create; +begin + FConnected := False; + FRequestType := JMC_HTTP_rtGet; + FParameters := TJMC_HTTP_ParameterArray.Create(Self); + FMultipartBoundary := '-------------------------------18788734234'; + FClientSocket := TClientSocket.Create(nil); + with FClientSocket do + begin + ClientType := ctNonBlocking; + OnConnect := ClientSocketConnect; + OnConnecting := ClientSocketConnecting; + OnDisconnect := ClientSocketDisconnect; + OnRead := ClientSocketRead; + OnError := ClientSocketError; + end; +end; + +destructor TJMC_HTTP_Request.Destroy; +begin + FClientSocket.Free; + FParameters.Free; + inherited; +end; + +procedure TJMC_HTTP_Request.DoError; +begin + if Assigned(FTimerPing) then + FTimerPing.Enabled := False; + if Assigned(FLabelStatus) then + FLabelStatus.Caption := 'SOCKET ERROR'; + Application.ProcessMessages; + if Assigned(FOnError) then + FOnError(Self); + FConnected := False; +end; + +procedure TJMC_HTTP_Request.SendRequest(const ServerAddress: string); +begin + FPingStart := GetTickCount; + if Assigned(FMemoReadStatus) then + FMemoReadStatus.Clear; + if Assigned(FMemoRequest) then + FMemoRequest.Clear; + if Assigned(FMemoResponseContent) then + FMemoResponseContent.Clear; + if Assigned(FMemoResponseHeaders) then + FMemoResponseHeaders.Clear; + FResponseContent := ''; + FResponseHeaders := ''; + FReadStatus := ''; + ParseAddress(ServerAddress, FPort, FHost, FRequest); + FClientSocket.Port := FPort; + FClientSocket.Host := FHost; + FClientSocket.Open; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_Math.pas b/delphi/lib/JMC_Math.pas new file mode 100644 index 0000000..6efe5c9 --- /dev/null +++ b/delphi/lib/JMC_Math.pas @@ -0,0 +1,35 @@ +unit JMC_Math; + +interface + +uses + Math; + +function JMC_ArcTan2(const Opposite: Double; const Adjacent: Double): Double; + +implementation + +function JMC_ArcTan2(const Opposite: Double; const Adjacent: Double): Double; +begin + Result := 0; + if (Opposite = 0) or (Adjacent = 0) then + begin + if (Opposite = 0) and (Adjacent = 0) then + Result := 0 + else + if Opposite = 0 then + if Adjacent < 0 then + Result := Pi + else + Result := 0; + if Adjacent = 0 then + if Opposite < 0 then + Result := -Pi / 2 + else + Result := Pi / 2; + end + else + Result := ArcTan2(Opposite, Adjacent); +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_Messaging.pas b/delphi/lib/JMC_Messaging.pas new file mode 100644 index 0000000..37bb388 --- /dev/null +++ b/delphi/lib/JMC_Messaging.pas @@ -0,0 +1,323 @@ +unit JMC_Messaging; + +interface + +uses + Classes, + SysUtils, + Sockets, + JMC_Strings, + Dialogs, + Windows, + Controls, + StdCtrls, + ExtCtrls, + Forms; + +type + + TJMC_Message = class; + TJMC_MessageArray = class; + TJMC_Messenger = class; + + TJMC_MessageReceivedEvent = procedure (const Sender: TJMC_Messenger; const Message: TJMC_Message; var Remove: Boolean) of object; + + TJMC_Message = class(TObject) + private + FMessage: TStringArray; + private + FRecipientAddress: string; + FRecipientListeningPort: string; + FSenderAddress: string; + FSenderListeningPort: string; + public + constructor Create; + destructor Destroy; override; + public + property Message: TStringArray read FMessage; + public + property RecipientAddress: string read FRecipientAddress write FRecipientAddress; + property RecipientListeningPort: string read FRecipientListeningPort write FRecipientListeningPort; + property SenderAddress: string read FSenderAddress write FSenderAddress; + property SenderListeningPort: string read FSenderListeningPort write FSenderListeningPort; + end; + + TJMC_MessageArray = class(TObject) + private + FMessages: TList; + private + function GetMessage(const Index: Integer): TJMC_Message; + function GetCount: Integer; + public + constructor Create; + destructor Destroy; override; + public + function Add: TJMC_Message; + procedure Delete(const Message: TJMC_Message); + public + property Messages[const Index: Integer]: TJMC_Message read GetMessage; default; + property Count: Integer read GetCount; + end; + + TJMC_Messenger = class(TObject) + private + FClient: TTcpClient; + FMessages: TJMC_MessageArray; + FServer: TTcpServer; + private + FOnClientConnect: TNotifyEvent; + FOnClientDisconnect: TNotifyEvent; + FOnClientError: TNotifyEvent; + FOnMessageReceived: TJMC_MessageReceivedEvent; + private + function GetDefaultSendingPort: string; + function GetListening: Boolean; + function GetListeningPort: string; + function GetLocalAddress: string; + function GetLocalName: string; + procedure SetDefaultSendingPort(const Value: string); + procedure SetListeningPort(const Value: string); + private + procedure ServerAccept(Sender: TObject; ClientSocket: TCustomIpClient); + private + procedure ClientConnect(Sender: TObject); + procedure ClientDisconnect(Sender: TObject); + procedure ClientError(Sender: TObject; SocketError: Integer); + procedure MessageReceived(const Message: TJMC_Message; var Remove: Boolean); + public + constructor Create; + destructor Destroy; override; + public + function AddressToName(const Address: string): string; + procedure CloseServer; + function NameToAddress(const Name: string): string; + procedure OpenServer; + function SendMessage(const Message, Address: string; const Port: string = ''): Boolean; + public + property Client: TTcpClient read FClient; + property DefaultSendingPort: string read GetDefaultSendingPort write SetDefaultSendingPort; + property Listening: Boolean read GetListening; + property ListeningPort: string read GetListeningPort write SetListeningPort; + property LocalAddress: string read GetLocalAddress; + property LocalName: string read GetLocalName; + property Messages: TJMC_MessageArray read FMessages; + property Server: TTcpServer read FServer; + public + property OnClientConnect: TNotifyEvent read FOnClientConnect write FOnClientConnect; + property OnClientDisconnect: TNotifyEvent read FOnClientDisconnect write FOnClientDisconnect; + property OnClientError: TNotifyEvent read FOnClientError write FOnClientError; + property OnMessageReceived: TJMC_MessageReceivedEvent read FOnMessageReceived write FOnMessageReceived; + end; + +implementation + +{ dynamic/private ports are 49152 through 65535 } + +{ TJMC_Message } + +constructor TJMC_Message.Create; +begin + FMessage := TStringArray.Create; +end; + +destructor TJMC_Message.Destroy; +begin + FMessage.Free; + inherited; +end; + +{ TJMC_MessageArray } + +function TJMC_MessageArray.Add: TJMC_Message; +begin + Result := TJMC_Message.Create; + FMessages.Add(Result); +end; + +constructor TJMC_MessageArray.Create; +begin + FMessages := TList.Create; +end; + +procedure TJMC_MessageArray.Delete(const Message: TJMC_Message); +var + i: Integer; +begin + for i := 0 to Count - 1 do + if Messages[i] = Message then + begin + FMessages.Delete(i); + Message.Free; + end; +end; + +destructor TJMC_MessageArray.Destroy; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Messages[i].Free; + FMessages.Free; + inherited; +end; + +function TJMC_MessageArray.GetCount: Integer; +begin + Result := FMessages.Count; +end; + +function TJMC_MessageArray.GetMessage(const Index: Integer): TJMC_Message; +begin + Result := FMessages[Index]; +end; + +{ TJMC_Messenger } + +function TJMC_Messenger.AddressToName(const Address: string): string; +begin + Result := FClient.LookupHostName(Address); +end; + +procedure TJMC_Messenger.ClientConnect(Sender: TObject); +begin + if Assigned(FOnClientConnect) then + begin + FOnClientConnect(Self); + Application.ProcessMessages; + end; +end; + +procedure TJMC_Messenger.ClientDisconnect(Sender: TObject); +begin + if Assigned(FOnClientDisconnect) then + begin + FOnClientDisconnect(Self); + Application.ProcessMessages; + end; +end; + +procedure TJMC_Messenger.ClientError(Sender: TObject; SocketError: Integer); +begin + if Assigned(FOnClientError) then + begin + FOnClientError(Self); + Application.ProcessMessages; + end; +end; + +procedure TJMC_Messenger.CloseServer; +begin + if FServer.Active then + FServer.Close; +end; + +constructor TJMC_Messenger.Create; +begin + FMessages := TJMC_MessageArray.Create; + FServer := TTcpServer.Create(nil); + FServer.OnAccept := ServerAccept; + FClient := TTcpClient.Create(nil); + FClient.OnConnect := ClientConnect; + FClient.OnDisconnect := ClientDisconnect; + FClient.OnError := ClientError; +end; + +destructor TJMC_Messenger.Destroy; +begin + FMessages.Free; + FClient.Free; + FServer.Free; + inherited; +end; + +function TJMC_Messenger.GetDefaultSendingPort: string; +begin + Result := FClient.RemotePort; +end; + +function TJMC_Messenger.GetListening: Boolean; +begin + Result := FServer.Active; +end; + +function TJMC_Messenger.GetListeningPort: string; +begin + Result := FServer.LocalPort; +end; + +function TJMC_Messenger.GetLocalAddress: string; +begin + Result := FClient.LocalHostAddr; +end; + +function TJMC_Messenger.GetLocalName: string; +begin + Result := FClient.LocalHostName; +end; + +procedure TJMC_Messenger.MessageReceived(const Message: TJMC_Message; var Remove: Boolean); +begin + if Assigned(FOnMessageReceived) then + begin + FOnMessageReceived(Self, Message, Remove); + Application.ProcessMessages; + end; +end; + +function TJMC_Messenger.NameToAddress(const Name: string): string; +begin + Result := FClient.LookupHostAddr(Name); +end; + +procedure TJMC_Messenger.OpenServer; +begin + FServer.Open; +end; + +function TJMC_Messenger.SendMessage(const Message, Address: string; const Port: string = ''): Boolean; +var + DefaultPort: string; +begin + FClient.RemoteHost := Address; + DefaultPort := FClient.RemotePort; + if Port <> '' then + FClient.RemotePort := Port; + try + Result := FClient.Connect; + if Result then + FClient.Sendln(FServer.LocalPort + #13#10 + Message, #0#0#0); + finally + FClient.Close; + end; + FClient.RemotePort := DefaultPort; +end; + +procedure TJMC_Messenger.ServerAccept(Sender: TObject; ClientSocket: TCustomIpClient); +var + Remove: Boolean; + Buffer: TJMC_Message; +begin + Remove := True; + Buffer := FMessages.Add; + Buffer.SenderAddress := ClientSocket.RemoteHost; + Buffer.RecipientAddress := ClientSocket.LocalHostAddr; + Buffer.RecipientListeningPort := FServer.LocalPort; + Buffer.Message.Text := ClientSocket.Receiveln(#0#0#0); + Buffer.SenderListeningPort := Buffer.Message[0]; + Buffer.Message.Delete(0); + MessageReceived(Buffer, Remove); + if Remove then + FMessages.Delete(Buffer); +end; + +procedure TJMC_Messenger.SetDefaultSendingPort(const Value: string); +begin + FClient.RemotePort := Value; +end; + +procedure TJMC_Messenger.SetListeningPort(const Value: string); +begin + FServer.LocalPort := Value; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_NetworkUtils.pas b/delphi/lib/JMC_NetworkUtils.pas new file mode 100644 index 0000000..d5a9b83 --- /dev/null +++ b/delphi/lib/JMC_NetworkUtils.pas @@ -0,0 +1,71 @@ +unit JMC_NetworkUtils; + +interface + +uses + Windows, + Classes, + SysUtils, + JMC_Strings; + +function FindComputers(const Computers: JMC_Strings.TStringArray): Boolean; + +implementation + +const + MAXENTRIES = 250; + +function FindComputers(const Computers: JMC_Strings.TStringArray): Boolean; +// http://www.infojet.cz/program/delphi/tips/tip0012.html [13 July 2008] +var + EnumWorkGroupHandle: THandle; + EnumComputerHandle: THandle; + EnumError: DWORD; + Network: TNetResource; + WorkGroupEntries: DWORD; + ComputerEntries: DWORD; + EnumWorkGroupBuffer: array[1..MAXENTRIES] of TNetResource; + EnumComputerBuffer: array[1..MAXENTRIES] of TNetResource; + EnumBufferLength: DWORD; + i: DWORD; + j: DWORD; +begin + Computers.Clear; + FillChar(Network, SizeOf(Network), 0); + with Network do + begin + dwScope := RESOURCE_GLOBALNET; + dwType := RESOURCETYPE_ANY; + dwUsage := RESOURCEUSAGE_CONTAINER; + end; + EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @Network, EnumWorkGroupHandle); + if EnumError = NO_ERROR then + begin + WorkGroupEntries := MAXENTRIES; + EnumBufferLength := SizeOf(EnumWorkGroupBuffer); + EnumError := WNetEnumResource(EnumWorkGroupHandle, WorkGroupEntries, @EnumWorkGroupBuffer, EnumBufferLength); + if EnumError = NO_ERROR then + begin + for i := 1 to WorkGroupEntries do + begin + EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @EnumWorkGroupBuffer[i], EnumComputerHandle); + if EnumError = NO_ERROR then + begin + ComputerEntries := MaxEntries; + EnumBufferLength := SizeOf(EnumComputerBuffer); + EnumError := WNetEnumResource(EnumComputerHandle, ComputerEntries, @EnumComputerBuffer, EnumBufferLength); + if EnumError = NO_ERROR then + for j := 1 to ComputerEntries do + Computers.Add(EnumComputerBuffer[j].lpRemoteName); + WNetCloseEnum(EnumComputerHandle); + end; + end; + end; + WNetCloseEnum(EnumWorkGroupHandle); + end; + if EnumError = ERROR_NO_MORE_ITEMS then + EnumError := NO_ERROR; + Result := EnumError = NO_ERROR; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_Parts.pas b/delphi/lib/JMC_Parts.pas new file mode 100644 index 0000000..c0b49e6 --- /dev/null +++ b/delphi/lib/JMC_Parts.pas @@ -0,0 +1,189 @@ +unit JMC_Parts; + +interface + +uses + SysUtils; + +function ReadPart(const S: string; const Index: Integer; const Sep: Char): string; overload; +function ReadPart(const S: string; const Index: Integer; const Sep: string): string; overload; +function WritePart(var S: string; const Part: string; const Index: Integer; const Sep: Char): Boolean; +function CountParts(const S: string; const Sep: Char): Integer; overload; +function CountParts(const S: string; const Sep: string): Integer; overload; +function SwapParts(var S: string; const Index1, Index2: Integer; const Sep: Char): Boolean; + +implementation + +function ReadPart(const S: string; const Index: Integer; const Sep: Char): string; +var + i, n: Integer; +begin + Result := ''; + n := 1; + for i := 1 to Length(S) do + begin + if S[i] = Sep then + Inc(n); + if n > Index then + Break; + if (n = Index) and (S[i] <> Sep) then + Result := Result + S[i]; + end; + Result := Trim(Result); +end; + +function ReadPart(const S: string; const Index: Integer; const Sep: string): string; +var + i, n: Integer; +begin + Result := ''; + n := 1; + i := 1; + while i <= Length(S) do + begin + if Copy(S, i, Length(Sep)) = Sep then + begin + Inc(n); + Inc(i, Length(Sep)); + end; + if n > Index then + Break; + if n = Index then + Result := Result + S[i]; + Inc(i); + end; + Result := Trim(Result); +end; + +function WritePart(var S: string; const Part: string; const Index: Integer; const Sep: Char): Boolean; +var + a, i, n: Integer; +begin + Result := False; + a := 0; + n := 1; + for i := 1 to Length(S) do + begin + if S[i] = Sep then + Inc(n); + if n = Index then + begin + a := i + 1; + Break; + end; + end; + if a > 0 then + begin + n := 0; + for i := a to Length(S) do + if S[i] <> Sep then + Inc(n) + else + Break; + Delete(S, a, n); + Insert(Part, S, a); + Result := True; + end; +end; + +function CountParts(const S: string; const Sep: Char): Integer; +var + i: Integer; +begin + if S = '' then + Result := 0 + else + begin + Result := 1; + for i := 1 to Length(S) do + if S[i] = Sep then + Inc(Result); + end; +end; + +function CountParts(const S: string; const Sep: string): Integer; +var + i, n: Integer; +begin + if S = '' then + begin + Result := 0; + Exit; + end; + n := 1; + i := 1; + while i <= Length(S) do + begin + if Copy(S, i, Length(Sep)) = Sep then + begin + Inc(n); + Inc(i, Length(Sep)); + end; + Inc(i); + end; + Result := n; +end; + +function SwapParts(var S: string; const Index1, Index2: Integer; const Sep: Char): Boolean; +var + i, n, i1, i2, j1, j2: Integer; + Part1, Part2, Backup: string; +begin + Result := not (Index1 = Index2); + if not Result then + Exit; + Backup := S; + i1 := 0; + i2 := 0; + j1 := 0; + j2 := 0; + Part1 := ''; + Part2 := ''; + n := 1; + i := 1; + repeat + if (n = Index1) and (i1 = 0) then + i1 := i; + if (n = Index1) and (j1 = 0) then + if S[i] = Sep then + j1 := i + else + if i = Length(S) then + j1 := i + 1; + if (n = Index2) and (i2 = 0) then + i2 := i; + if (n = Index2) and (j2 = 0) then + if S[i] = Sep then + j2 := i + else + if i = Length(S) then + j2 := i + 1; + if S[i] = Sep then + Inc(n); + Inc(i); + until i > Length(S); + Result := (i1 > 0) and (i2 > 0) and (j1 > 0) and (j2 > 0); + if not Result then + Exit; + Part1 := Copy(S, i1, j1 - i1); + Part2 := Copy(S, i2, j2 - i2); + if i2 > i1 then + begin + Delete(S, i2, j2 - i2); + Delete(S, i1, j1 - i1); + Insert(Part2, S, i1); + Insert(Part1, S, i2); + end + else + begin + Delete(S, i1, j1 - i1); + Delete(S, i2, j2 - i2); + Insert(Part1, S, i2); + Insert(Part2, S, i1); + end; + Result := (Length(S) = Length(Backup)) and (i1 > 0) and (i2 > 0); + if not Result then + S := Backup; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_PathFinding.pas b/delphi/lib/JMC_PathFinding.pas new file mode 100644 index 0000000..f140115 --- /dev/null +++ b/delphi/lib/JMC_PathFinding.pas @@ -0,0 +1,165 @@ +{ While I wrote this unit myself, a pathfinding algorithm contained in a unit + called 'DXPath' developed by John Christian Lonningdal in 1996 was referred + to for initial understanding. After reading through and understanding this + person's algorithm, I thought there was some parts that were unneccessary, + so I went about designing this algorithm from scratch. It uses the same + general principle as 'DXPath', but is shorter and more understandable. It + still requires work though. + + POSSIBLE IMPROVEMENTS: + + 1. Make it so that the legs of the path can be any angle (instead of just + the 45 degrees currently used). } + +unit JMC_PathFinding; + +interface + +uses + Windows, + SysUtils, + Classes, + Dialogs; + +type + + TObstacleMap = array of array of Boolean; // True => Obstacle + + PObstacleMap = ^TObstacleMap; + + TPathPoint = record + Location : TPoint; + Direction : Integer; + end; + + TPath = array of TPathPoint; + + PPath = ^TPath; + +var + MapWidth, MapHeight : Integer; // These are the dimensions of the map that units can move on, which doesn't have to be the same as the dimensions of the terrain map (the FindPath function doesn't have to rely on the terrain map in any way). + +function FindPath(const Path : PPath; const Start, Finish : TPoint; const ObstacleMap : PObstacleMap) : Boolean; + +implementation + +const + Directions : array[0..1, 0..7] of Integer = ((0, 1, 0, -1, -1, 1, -1, 1), (-1, 0, 1, 0, -1, -1, 1, 1)); + { Row 0 = X Directions + Row 1 = Y Directions + Columns - Directions: + 0 = Up + 1 = Right + 2 = Down + 3 = Left + 4 = Up & Left + 5 = Up & Right + 6 = Down & Left + 7 = Down & Right + 255 = None } + +function FindPath(const Path : PPath; const Start, Finish : TPoint; const ObstacleMap : PObstacleMap) : Boolean; +// This algorithm will find the most direct path between the finish and start locations, if one exists. +// Returns true if a path is found, otherwise returns false. +var + Direction, LocationsCount, PathLength, LocationIndex, x, y : Integer; + DirectionMap : array of array of Integer; + Locations : array of TPoint; + InversePath : TPath; + CurrentLocation : TPoint; +begin + if (Start.x < 0) or (Start.x >= MapWidth) or (Finish.x < 0) or (Finish.x >= MapWidth) or (Start.y < 0) or (Start.y >= MapHeight) or (Finish.y < 0) or (Finish.y >= MapHeight) then + begin + Result := False; + ShowMessage('(Start.x < 0) or (Start.x >= MapWidth) or (Finish.x < 0) or (Finish.x >= MapWidth) or (Start.y < 0) or (Start.y >= MapHeight) or (Finish.y < 0) or (Finish.y >= MapHeight)'); + Exit; + end; + if Length(ObstacleMap^) <> MapHeight then + begin + Result := False; + ShowMessage('Length(ObstacleMap) <> MapHeight'); + Exit; + end; + if Length(ObstacleMap^[0]) <> MapWidth then + begin + Result := False; + ShowMessage('Length(ObstacleMap[0]) <> MapWidth'); + Exit; + end; + if ObstacleMap^[Start.y, Start.x] or ObstacleMap^[Finish.y, Finish.x] then + begin + Result := False; + ShowMessage('ObstacleMap^[Start.y, Start.x] or ObstacleMap^[Finish.y, Finish.x]'); + Exit; + end; + // Initialize the direction map with 255 (no direction). + SetLength(DirectionMap, MapHeight, MapWidth); + for y := 0 to MapHeight - 1 do + for x := 0 to MapWidth - 1 do + DirectionMap[y, x] := 255; + LocationsCount := 0; + LocationIndex := -1; + CurrentLocation := Start; + repeat + // Test for traversable locations in all directions around the current location. + for Direction := 0 to 7 do + begin + x := CurrentLocation.x + Directions[0, Direction]; + y := CurrentLocation.y + Directions[1, Direction]; + // If the point at (x, y) is traversable, add it to the locations array if it hasn't already been added, and add the direction relative to the current location to the direction map. + if (x >= 0) and (y >= 0) and (x < MapWidth) and (y < MapHeight) then + if (not ObstacleMap^[y, x]) and (DirectionMap[y, x] = 255) then + begin + Inc(LocationsCount); + SetLength(Locations, LocationsCount); + Locations[LocationsCount - 1] := Point(x, y); + DirectionMap[y, x] := Direction; + end; + end; + // The current location has been fully tested. Move on to the next traversable location stored in the locations array. + Inc(LocationIndex); + if LocationIndex >= Length(Locations) then + begin + SetLength(DirectionMap, 0); + SetLength(Locations, 0); + SetLength(InversePath, 0); + Result := False; + ShowMessage('LocationIndex >= Length(Locations)'); + Exit; + end; + CurrentLocation := Locations[LocationIndex]; + // If the current location is the same as the finish location, a path has been found (break from the searching loop). + until (CurrentLocation.x = Finish.x) and (CurrentLocation.y = Finish.y); + PathLength := 1; + SetLength(InversePath, PathLength); + InversePath[0].Location := CurrentLocation; + InversePath[0].Direction := DirectionMap[CurrentLocation.y, CurrentLocation.x]; + // Start from the finish and work back to the start, following the inverted directions and adding locations as you go. + repeat + Direction := DirectionMap[CurrentLocation.y, CurrentLocation.x]; + // To invert the direction, subtract the ordinal in the directions array instead of adding it. + CurrentLocation.x := CurrentLocation.x - Directions[0, Direction]; + CurrentLocation.y := CurrentLocation.y - Directions[1, Direction]; + Inc(PathLength); + SetLength(InversePath, PathLength); + InversePath[PathLength - 1].Location := CurrentLocation; + InversePath[PathLength - 1].Direction := Direction; + // When the start location is reached, break from the loop. + until (CurrentLocation.x = Start.x) and (CurrentLocation.y = Start.y); + SetLength(Path^, PathLength); + // Copy the points from InversePath into Path in the opposite order. + y := PathLength - 1; + for x := 0 to PathLength - 1 do + begin + Path^[x] := InversePath[y]; + Dec(y); + end; + // Free memory from temporary arrays. + SetLength(DirectionMap, 0); + SetLength(Locations, 0); + SetLength(InversePath, 0); + // Path has been successfully found (and is stored in the array that Path points to). + Result := True; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_Processes.pas b/delphi/lib/JMC_Processes.pas new file mode 100644 index 0000000..b0b49b6 --- /dev/null +++ b/delphi/lib/JMC_Processes.pas @@ -0,0 +1,188 @@ +unit JMC_Processes; + +interface + +uses + Classes, + ShellApi, + SysUtils, + TLHelp32, + Windows; + +type + + { TProcessInfo } + + TProcessInfo = class(TObject) + private + FBasePriority: Longint; + FDefaultHeapID: Cardinal; + FExecutableFile: string; + FModuleID: Cardinal; + FParentProcessID: Cardinal; + FProcessID: Cardinal; + FThreadCount: Cardinal; + FUsageCount: Cardinal; + public + constructor Create(var ProcessEntry: TProcessEntry32); + property BasePriority: Longint read FBasePriority; + property DefaultHeapID: Cardinal read FDefaultHeapID; + property ExecutableFile: string read FExecutableFile; + property ModuleID: Cardinal read FModuleID; + property ParentProcessID: Cardinal read FParentProcessID; + property ProcessID: Cardinal read FProcessID; + property ThreadCount: Cardinal read FThreadCount; + property UsageCount: Cardinal read FUsageCount; + end; + + { TProcessInfoArray } + + TProcessInfoArray = class(TObject) + private + FProcesses: TList; + private + procedure AddProcess(var ProcessEntry: TProcessEntry32); + function GetCount: Integer; + function GetProcess(const Index: Integer): TProcessInfo; + public + constructor Create; + destructor Destroy; override; + public + procedure Clear; + function Exists(const FileName: string): Boolean; + function IndexOf(const FileName: string): Integer; + procedure Refresh; + function Terminate(const FileName: string): Boolean; + public + property Count: Integer read GetCount; + property Processes[const Index: Integer]: TProcessInfo read GetProcess; default; + end; + +implementation + +{ TProcessInfo } + +constructor TProcessInfo.Create(var ProcessEntry: TProcessEntry32); +begin + FBasePriority := ProcessEntry.pcPriClassBase; + FDefaultHeapID := ProcessEntry.th32DefaultHeapID; + FExecutableFile := string(ProcessEntry.szExeFile); + FModuleID := ProcessEntry.th32ModuleID; + FParentProcessID := ProcessEntry.th32ParentProcessID; + FProcessID := ProcessEntry.th32ProcessID; + FThreadCount := ProcessEntry.cntThreads; + FUsageCount := ProcessEntry.cntUsage; +end; + +{ TProcessInfoArray } + +procedure TProcessInfoArray.AddProcess(var ProcessEntry: TProcessEntry32); +begin + FProcesses.Add(TProcessInfo.Create(ProcessEntry)); +end; + +procedure TProcessInfoArray.Clear; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Processes[i].Free; + FProcesses.Clear; +end; + +constructor TProcessInfoArray.Create; +begin + FProcesses := TList.Create; + Refresh; +end; + +destructor TProcessInfoArray.Destroy; +begin + Clear; + FProcesses.Free; + inherited; +end; + +function TProcessInfoArray.Exists(const FileName: string): Boolean; +begin + Result := IndexOf(FileName) >= 0; +end; + +function TProcessInfoArray.GetCount: Integer; +begin + Result := FProcesses.Count; +end; + +function TProcessInfoArray.GetProcess(const Index: Integer): TProcessInfo; +begin + Result := FProcesses[Index]; +end; + +function TProcessInfoArray.IndexOf(const FileName: string): Integer; +var + i: Integer; + S: string; +begin + S := UpperCase(FileName); + for i := 0 to Count - 1 do + if UpperCase(ExtractFileName(Processes[i].ExecutableFile)) = S then + begin + Result := i; + Exit; + end; + Result := -1; +end; + +procedure TProcessInfoArray.Refresh; +var + SnapShot: THandle; + ProcessEntry: TProcessEntry32; +begin + Clear; + SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + try + if SnapShot <> 0 then + begin + ProcessEntry.dwSize := SizeOf(TProcessEntry32); + if Process32First(SnapShot, ProcessEntry) then + begin + AddProcess(ProcessEntry); + while Process32Next(SnapShot, ProcessEntry) do + AddProcess(ProcessEntry); + end; + end; + finally + CloseHandle(SnapShot); + end; +end; + +function TProcessInfoArray.Terminate(const FileName: string): Boolean; +var + Handle: THandle; + i: Integer; + ExitCode: Cardinal; +begin + i := IndexOf(FileName); + Result := i <> -1; + if Result then + begin + Handle := OpenProcess(1, False, Processes[i].ProcessID); + try + Result := Handle <> 0; + if Result then + begin + Result := GetExitCodeProcess(Handle, ExitCode); + if Result then + begin + Result := TerminateProcess(Handle, ExitCode); + if Result then + Result := WaitForSingleObject(Handle, INFINITE) = WAIT_OBJECT_0; + end; + end; + finally + CloseHandle(Handle); + end; + end; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_SocketMessaging.pas b/delphi/lib/JMC_SocketMessaging.pas new file mode 100644 index 0000000..48418be --- /dev/null +++ b/delphi/lib/JMC_SocketMessaging.pas @@ -0,0 +1,338 @@ +unit JMC_SocketMessaging; + +interface + +uses + Classes, + SysUtils, + Sockets, + JMC_Strings, + Dialogs, + Windows, + Controls, + StdCtrls, + ExtCtrls, + Forms; + +type + + TSM_ClientThread = class; + TSM_Message = class; + TSM_MessageArray = class; + TSM_Messenger = class; + + TSM_MessageReceivedEvent = procedure (const Sender: TSM_Messenger; const Message: TSM_Message; var Remove: Boolean) of object; + + TSM_ClientThread = class(TThread) + private + FBuffer: TSM_Message; + FMessenger: TSM_Messenger; + public + constructor Create(CreateSuspended: Boolean); + procedure Update; + procedure Execute; override; + public + property Buffer: TSM_Message read FBuffer; + property Messenger: TSM_Messenger read FMessenger write FMessenger; + end; + + TSM_Message = class(TObject) + private + FMessage: TStringArray; + FRemoteAddress: string; + public + constructor Create; + destructor Destroy; override; + public + property Message: TStringArray read FMessage; + property RemoteAddress: string read FRemoteAddress write FRemoteAddress; + end; + + TSM_MessageArray = class(TObject) + private + FMessages: TList; + private + function GetMessage(const Index: Integer): TSM_Message; + function GetCount: Integer; + public + constructor Create; + destructor Destroy; override; + public + procedure Add(const Message: TSM_Message); + procedure Delete(const Message: TSM_Message); + public + property Messages[const Index: Integer]: TSM_Message read GetMessage; default; + property Count: Integer read GetCount; + end; + + TSM_Messenger = class(TObject) + private + FClient: TTcpClient; + FMessages: TSM_MessageArray; + FServer: TTcpServer; + private + FOnClientConnect: TNotifyEvent; + FOnClientDisconnect: TNotifyEvent; + FOnClientError: TNotifyEvent; + FOnMessageReceived: TSM_MessageReceivedEvent; + private + function GetListening: Boolean; + function GetListeningPort: string; + function GetLocalAddress: string; + function GetLocalName: string; + function GetSendingPort: string; + procedure SetListeningPort(const Value: string); + procedure SetSendingPort(const Value: string); + private + procedure ServerAccept(Sender: TObject; ClientSocket: TCustomIpClient); + private + procedure ClientConnect(Sender: TObject); + procedure ClientDisconnect(Sender: TObject); + procedure ClientError(Sender: TObject; SocketError: Integer); + procedure MessageReceived(const Message: TSM_Message; var Remove: Boolean); + public + constructor Create; + destructor Destroy; override; + public + function AddressToName(const Address: string): string; + procedure CloseServer; + function NameToAddress(const Name: string): string; + procedure OpenServer; + function SendMessage(const Message, Address: string): Boolean; + public + property Client: TTcpClient read FClient; + property Listening: Boolean read GetListening; + property ListeningPort: string read GetListeningPort write SetListeningPort; + property LocalAddress: string read GetLocalAddress; + property LocalName: string read GetLocalName; + property Messages: TSM_MessageArray read FMessages; + property SendingPort: string read GetSendingPort write SetSendingPort; + property Server: TTcpServer read FServer; + public + property OnClientConnect: TNotifyEvent read FOnClientConnect write FOnClientConnect; + property OnClientDisconnect: TNotifyEvent read FOnClientDisconnect write FOnClientDisconnect; + property OnClientError: TNotifyEvent read FOnClientError write FOnClientError; + property OnMessageReceived: TSM_MessageReceivedEvent read FOnMessageReceived write FOnMessageReceived; + end; + +implementation + +{ TAR_ClientThread } + +constructor TSM_ClientThread.Create(CreateSuspended: Boolean); +begin + inherited; + FreeOnTerminate := True; + FBuffer := TSM_Message.Create; +end; + +procedure TSM_ClientThread.Execute; +begin + Synchronize(Update); +end; + +procedure TSM_ClientThread.Update; +var + Remove: Boolean; +begin + Remove := True; + FMessenger.Messages.Add(FBuffer); + FMessenger.MessageReceived(FBuffer, Remove); + if Remove then + FMessenger.Messages.Delete(FBuffer); +end; + +{ TSM_Message } + +constructor TSM_Message.Create; +begin + FMessage := TStringArray.Create; +end; + +destructor TSM_Message.Destroy; +begin + FMessage.Free; + inherited; +end; + +{ TSM_MessageArray } + +procedure TSM_MessageArray.Add(const Message: TSM_Message); +begin + FMessages.Add(Message); +end; + +constructor TSM_MessageArray.Create; +begin + FMessages := TList.Create; +end; + +procedure TSM_MessageArray.Delete(const Message: TSM_Message); +var + i: Integer; +begin + for i := 0 to Count - 1 do + if Messages[i] = Message then + begin + FMessages.Delete(i); + Message.Free; + end; +end; + +destructor TSM_MessageArray.Destroy; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Messages[i].Free; + FMessages.Free; + inherited; +end; + +function TSM_MessageArray.GetCount: Integer; +begin + Result := FMessages.Count; +end; + +function TSM_MessageArray.GetMessage(const Index: Integer): TSM_Message; +begin + Result := FMessages[Index]; +end; + +{ TSM_Messenger } + +function TSM_Messenger.AddressToName(const Address: string): string; +begin + Result := FClient.LookupHostName(Address); +end; + +procedure TSM_Messenger.ClientConnect(Sender: TObject); +begin + if Assigned(FOnClientConnect) then + begin + FOnClientConnect(Self); + Application.ProcessMessages; + end; +end; + +procedure TSM_Messenger.ClientDisconnect(Sender: TObject); +begin + if Assigned(FOnClientDisconnect) then + begin + FOnClientDisconnect(Self); + Application.ProcessMessages; + end; +end; + +procedure TSM_Messenger.ClientError(Sender: TObject; SocketError: Integer); +begin + if Assigned(FOnClientError) then + begin + FOnClientError(Self); + Application.ProcessMessages; + end; +end; + +procedure TSM_Messenger.CloseServer; +begin + if FServer.Active then + FServer.Close; +end; + +constructor TSM_Messenger.Create; +begin + FMessages := TSM_MessageArray.Create; + FServer := TTcpServer.Create(nil); + FServer.OnAccept := ServerAccept; + FClient := TTcpClient.Create(nil); + FClient.OnConnect := ClientConnect; + FClient.OnDisconnect := ClientDisconnect; + FClient.OnError := ClientError; +end; + +destructor TSM_Messenger.Destroy; +begin + FMessages.Free; + FClient.Free; + FServer.Free; + inherited; +end; + +function TSM_Messenger.GetListening: Boolean; +begin + Result := FServer.Active; +end; + +function TSM_Messenger.GetListeningPort: string; +begin + Result := FServer.LocalPort; +end; + +function TSM_Messenger.GetLocalAddress: string; +begin + Result := FClient.LocalHostAddr; +end; + +function TSM_Messenger.GetLocalName: string; +begin + Result := FClient.LocalHostName; +end; + +function TSM_Messenger.GetSendingPort: string; +begin + Result := FClient.RemotePort; +end; + +procedure TSM_Messenger.MessageReceived(const Message: TSM_Message; var Remove: Boolean); +begin + if Assigned(FOnMessageReceived) then + begin + FOnMessageReceived(Self, Message, Remove); + Application.ProcessMessages; + end; +end; + +function TSM_Messenger.NameToAddress(const Name: string): string; +begin + Result := FClient.LookupHostAddr(Name); +end; + +procedure TSM_Messenger.OpenServer; +begin + FServer.Open; +end; + +function TSM_Messenger.SendMessage(const Message, Address: string): Boolean; +begin + FClient.RemoteHost := Address; + try + Result := FClient.Connect; + if Result then + FClient.Sendln(Message, #0); + finally + FClient.Close; + end; +end; + +procedure TSM_Messenger.ServerAccept(Sender: TObject; ClientSocket: TCustomIpClient); +var + ClientThread: TSM_ClientThread; +begin + ClientThread := TSM_ClientThread.Create(True); + ClientThread.Buffer.RemoteAddress := ClientSocket.RemoteHost; + ClientThread.Buffer.Message.Text := ClientSocket.Receiveln(#0); + ClientThread.Messenger := Self; + ClientThread.Resume; +end; + +procedure TSM_Messenger.SetListeningPort(const Value: string); +begin + FServer.LocalPort := Value; +end; + +procedure TSM_Messenger.SetSendingPort(const Value: string); +begin + FClient.RemotePort := Value; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_Strings.pas b/delphi/lib/JMC_Strings.pas new file mode 100644 index 0000000..000d749 --- /dev/null +++ b/delphi/lib/JMC_Strings.pas @@ -0,0 +1,888 @@ +// Modified April 2010 +// TCustomStrings.SetText method modified to account for either #10, #13 or #13#10 as line breaks + +unit JMC_Strings; + +interface + +uses + Classes, + JMC_Parts, + Graphics, + Windows, + SysUtils, + Clipbrd, + JMC_FileUtils; + +type + + { TCustomStrings } + + TCustomStrings = class(TObject) + protected + function IndexInRange(const Index: Integer): Boolean; + function GetCount: Integer; virtual; abstract; + function GetLine(const Index: Integer): string; virtual; abstract; + function GetText: string; + procedure SetLine(const Index: Integer; const Value: string); virtual; abstract; + procedure SetText(const Value: string); + procedure Ins(const Index: Integer; const Line: string); virtual; abstract; + procedure Del(const Index: Integer); virtual; abstract; + public + constructor Create; virtual; + function LoadFromFile(const FileName: string): Boolean; virtual; abstract; + function SaveToFile(const FileName: string): Boolean; virtual; abstract; + procedure Add; overload; virtual; + procedure Add(const Line: string); overload; virtual; abstract; + procedure Append(const Index: Integer; const Value: string); + procedure AppendFrom(const Lines: TCustomStrings); overload; + procedure AppendFrom(const Lines: TStrings); overload; + procedure AppendTo(const Lines: TCustomStrings); overload; + procedure AppendTo(const Lines: TStrings); overload; + function Insert(const Index: Integer; const Line: string): Boolean; + function Delete(const Index: Integer): Boolean; + procedure Clear; virtual; abstract; + procedure Assign(const Strings: TStrings); overload; + procedure Assign(const Strings: TCustomStrings); overload; + procedure CopyToClipboard; + procedure CopyToStrings(const Strings: TStrings); + function Equals(const Strings: TCustomStrings): Boolean; + function Empty: Boolean; + function Find(const Line: string): Integer; + function MaxWidth(const Canvas: TCanvas): Integer; + property Text: string read GetText write SetText; + property Count: Integer read GetCount; + property Lines[const Index: Integer]: string read GetLine write SetLine; default; + end; + + { TStringArray } + + TStringArray = class(TCustomStrings) + protected + FCount: Integer; + FLines: array of string; + function GetCount: Integer; override; + function GetLine(const Index: Integer): string; override; + procedure SetLine(const Index: Integer; const Value: string); override; + procedure Ins(const Index: Integer; const Line: string); override; + procedure Del(const Index: Integer); override; + public + destructor Destroy; override; + function LoadFromFile(const FileName: string): Boolean; override; + function SaveToFile(const FileName: string): Boolean; override; + procedure Clear; override; + procedure Add(const Line: string); override; + end; + + { TCustomIniFile } + + TCustomIniFile = class(TObject) + private + FStrings: TCustomStrings; + function SectionFound(const LineIndex: Integer): Boolean; + protected + procedure SetStrings(const Value: TCustomStrings); + public + constructor Create; virtual; + function LoadFromFile(const FileName: string): Boolean; virtual; + function SaveToFile(const FileName: string): Boolean; virtual; + { Parts } + function ReadPart(const LineIndex, PartIndex: Integer): string; + function WritePart(const Part: string; const LineIndex, PartIndex: Integer): Boolean; + { Sections } + function WriteSection(const Section: string): Boolean; + function ReadSections(const Lines: TCustomStrings): Boolean; + function SectionIndex(const Section: string): Integer; + function SectionExists(const Section: string): Boolean; + function CountSections: Integer; + function RenameSection(const OldSection, NewSection: string): Boolean; + function DeleteSection(const Section: string): Boolean; + function ClearSection(const Section: string): Boolean; + { Keys } + function ReadKeys(const Section: string; const Lines: TCustomStrings): Boolean; + function KeyIndex(const Section, Key: string): Integer; + function KeyExists(const Section, Key: string): Boolean; + function CountKeys(const Section: string): Integer; + function RenameKey(const Section, OldKey, NewKey: string): Boolean; + function DeleteKey(const Section, Key: string): Boolean; + { Values } + function ReadValue(const Section, Key: string): string; + function ReadValues(const Section: string; const Lines: TCustomStrings): Boolean; + function WriteValue(const Section, Key, Value: string): Boolean; + { Lines } + function ReadLine(const Section: string; const Index: Integer): string; + function ReadLines(const Section: string; const Lines: TCustomStrings; const SkipBlanks, TrimSpaces, AllowEmpty: Boolean): Boolean; + procedure WriteLine(const Section, NewLine: string); + procedure WriteLines(const Section: string; const Lines: TCustomStrings); + function LineIndex(const Section, Line: string): Integer; + function LineExists(const Section, Line: string): Boolean; + function CountLines(const Section: string): Integer; + function NextEmptyLineIndex(const StartIndex: Integer): Integer; overload; + function NextEmptyLineIndex(const Section: string): Integer; overload; + function ChangeLine(const Section, OldLine, NewLine: string): Boolean; + function DeleteLine(const Section, Line: string): Boolean; + { Properties } + property Strings: TCustomStrings read FStrings; + end; + + { TLinkedIniFile } + + TLinkedIniFile = class(TCustomIniFile) + public + property Strings write SetStrings; + end; + + { TStoredIniFile } + + TStoredIniFile = class(TCustomIniFile) + public + constructor Create; override; + destructor Destroy; override; + end; + +implementation + +{ TCustomStrings } + +procedure TCustomStrings.Add; +begin + Add(''); +end; + +procedure TCustomStrings.Append(const Index: Integer; const Value: string); +begin + Lines[Index] := Lines[Index] + Value; +end; + +procedure TCustomStrings.AppendFrom(const Lines: TCustomStrings); +var + i: Integer; +begin + for i := 0 to Lines.Count - 1 do + Add(Lines[i]); +end; + +procedure TCustomStrings.AppendFrom(const Lines: TStrings); +var + i: Integer; +begin + for i := 0 to Lines.Count - 1 do + Add(Lines[i]); +end; + +procedure TCustomStrings.AppendTo(const Lines: TCustomStrings); +var + i: Integer; +begin + for i := 0 to Count - 1 do + Lines.Add(GetLine(i)); +end; + +procedure TCustomStrings.AppendTo(const Lines: TStrings); +var + i: Integer; +begin + for i := 0 to Count - 1 do + Lines.Add(GetLine(i)); +end; + +procedure TCustomStrings.Assign(const Strings: TCustomStrings); +var + i: Integer; +begin + Clear; + for i := 0 to Strings.Count - 1 do + Add(Strings[i]); +end; + +procedure TCustomStrings.Assign(const Strings: TStrings); +begin + SetText(Strings.Text); +end; + +procedure TCustomStrings.CopyToClipboard; +begin + Clipboard.SetTextBuf(PChar(Text)); +end; + +procedure TCustomStrings.CopyToStrings(const Strings: TStrings); +Begin + Strings.Text := GetText; +end; + +constructor TCustomStrings.Create; +begin + inherited; +end; + +function TCustomStrings.Delete(const Index: Integer): Boolean; +begin + Result := IndexInRange(Index); + if Result then + Del(Index); +end; + +function TCustomStrings.Empty: Boolean; +begin + Result := Count = 0; +end; + +function TCustomStrings.Equals(const Strings: TCustomStrings): Boolean; +var + i: Integer; +begin + Result := Count = Strings.Count; + if Result then + for i := 0 to Count - 1 do + if CompareStr(Lines[i], Strings[i]) <> 0 then + begin + Result := False; + Exit; + end; +end; + +function TCustomStrings.Find(const Line: string): Integer; +var + i: Integer; + S: string; +begin + S := UpperCase(Line); + for i := 0 to Count - 1 do + if UpperCase(Lines[i]) = S then + begin + Result := i; + Exit; + end; + Result := -1; +end; + +function TCustomStrings.GetText: string; +var + i: Integer; +begin + Result := ''; + for i := 0 to Count - 1 do + begin + Result := Result + Lines[i]; + if i < Count - 1 then + Result := Result + #13#10; + end; +end; + +function TCustomStrings.IndexInRange(const Index: Integer): Boolean; +begin + Result := (Index >= 0) and (Index < Count); +end; + +function TCustomStrings.Insert(const Index: Integer; const Line: string): Boolean; +begin + Result := IndexInRange(Index); + if Result then + Ins(Index, Line); +end; + +function TCustomStrings.MaxWidth(const Canvas: TCanvas): Integer; +var + i: Integer; +begin + Result := 0; + for i := 0 to Count - 1 do + if Canvas.TextWidth(Lines[i]) > Result then + Result := Canvas.TextWidth(Lines[i]); +end; + +procedure TCustomStrings.SetText(const Value: string); +var + i: Integer; + S: string; +begin + Clear; + if Value = '' then + Exit; + i := 1; + S := ''; + while i <= Length(Value) do + begin + case Ord(Value[i]) of + 10, 13: + begin + Add(S); + S := ''; + if (Ord(Value[i]) = 13) and (i < Length(Value)) then + if Ord(Value[i + 1]) = 10 then + Inc(i); + end; + else + S := S + Value[i]; + end; + Inc(i); + end; + Add(S); +end; + +{ TStringArray } + +procedure TStringArray.Add(const Line: string); +begin + Inc(FCount); + SetLength(FLines, FCount); + FLines[FCount - 1] := Line; +end; + +procedure TStringArray.Clear; +begin + SetLength(FLines, 0); + FCount := 0; +end; + +procedure TStringArray.Del(const Index: Integer); +var + i: Integer; +begin + Dec(FCount); + for i := Index to FCount - 1 do + FLines[i] := FLines[i + 1]; + SetLength(FLines, FCount); +end; + +destructor TStringArray.Destroy; +begin + SetLength(FLines, 0); + inherited; +end; + +function TStringArray.GetCount: Integer; +begin + Result := FCount; +end; + +function TStringArray.GetLine(const Index: Integer): string; +begin + if IndexInRange(Index) then + Result := FLines[Index] + else + Result := ''; +end; + +procedure TStringArray.Ins(const Index: Integer; const Line: string); +var + i: Integer; +begin + Inc(FCount); + SetLength(FLines, FCount); + for i := FCount - 1 downto Index + 1 do + FLines[i] := FLines[i - 1]; + FLines[Index] := Line; +end; + +function TStringArray.LoadFromFile(const FileName: string): Boolean; +var + S: string; +begin + Result := JMC_FileUtils.FileToStr(FileName, S); + SetText(S); +end; + +function TStringArray.SaveToFile(const FileName: string): Boolean; // FileName must be fully qualified +var + F: TFileStream; + i: Integer; + S: string; +begin + try + if Count > 0 then + begin + F := TFileStream.Create(FileName, fmCreate or fmOpenWrite or fmShareDenyNone); + for i := 0 to Count - 2 do + begin + S := FLines[i] + #13#10; + F.Write(S[1], Length(S)); + end; + F.Write(FLines[Count - 1][1], Length(FLines[Count - 1])); + F.Free; + Result := True; + end + else + Result := False; + except + Result := False; + end; +end; + +procedure TStringArray.SetLine(const Index: Integer; const Value: string); +begin + if IndexInRange(Index) then + FLines[Index] := Value; +end; + +{ TCustomIniFile } + +function TCustomIniFile.ChangeLine(const Section, OldLine, NewLine: string): Boolean; +var + i: Integer; +begin + i := LineIndex(Section, OldLine); + Result := i > -1; + if Result then + FStrings[i] := NewLine; +end; + +function TCustomIniFile.ClearSection(const Section: string): Boolean; +var + i: Integer; +begin + i := SectionIndex(Section); + Result := i > -1; + if Result then + begin + Inc(i); + while i < FStrings.Count do + begin + if SectionFound(i) then + Break; + FStrings.Del(i); + Inc(i); + end; + end; +end; + +function TCustomIniFile.CountKeys(const Section: string): Integer; +var + i, n: Integer; +begin + Result := 0; + i := SectionIndex(Section); + if i > -1 then + for n := i to FStrings.Count - 1 do + begin + if SectionFound(n) then + Break; + if Pos('=', FStrings[n]) > 0 then + Inc(Result); + end; +end; + +function TCustomIniFile.CountLines(const Section: string): Integer; +var + n, i: Integer; +begin + Result := 0; + i := SectionIndex(Section) + 1; + if i > -1 then + for n := i to FStrings.Count - 1 do + begin + if SectionFound(n) then + Break; + Inc(Result); + end; +end; + +function TCustomIniFile.CountSections: Integer; +var + i: Integer; +begin + Result := 0; + for i := 0 to FStrings.Count - 1 do + if SectionFound(i) then + Inc(Result); +end; + +constructor TCustomIniFile.Create; +begin + inherited; +end; + +function TCustomIniFile.DeleteKey(const Section, Key: string): Boolean; +var + i: Integer; +begin + i := KeyIndex(Section, Key); + Result := i > -1; + if Result then + FStrings.Delete(i); +end; + +function TCustomIniFile.DeleteLine(const Section, Line: string): Boolean; +var + i: Integer; +begin + i := LineIndex(Section, Line); + Result := i <> -1; + if Result then + FStrings.Delete(i); +end; + +function TCustomIniFile.DeleteSection(const Section: string): Boolean; +var + i: Integer; +begin + i := SectionIndex(Section); + Result := i > -1; + if Result then + begin + FStrings.Del(i); + while i < FStrings.Count do + begin + if SectionFound(i) then + Break; + FStrings.Del(i); + Inc(i); + end; + end; +end; + +function TCustomIniFile.KeyExists(const Section, Key: string): Boolean; +begin + Result := KeyIndex(Section, Key) > -1; +end; + +function TCustomIniFile.KeyIndex(const Section, Key: string): Integer; +var + i, n: Integer; +begin + i := SectionIndex(Section); + if i > -1 then + for n := i + 1 to FStrings.Count - 1 do + begin + if SectionFound(n) then + Break; + if Pos('=', FStrings[n]) <= 0 then + Break; + if UpperCase(JMC_Parts.ReadPart(FStrings[n], 1, '=')) = UpperCase(Key) then + begin + Result := n; + Exit; + end; + end; + Result := -1; +end; + +function TCustomIniFile.LineExists(const Section, Line: string): Boolean; +begin + Result := LineIndex(Section, Line) > -1; +end; + +function TCustomIniFile.LineIndex(const Section, Line: string): Integer; +var + n, i: Integer; +begin + i := SectionIndex(Section); + if i > -1 then + for n := i + 1 to FStrings.Count - 1 do + begin + if SectionFound(n) then + Break; + if FStrings[n] = Line then + begin + Result := n; + Exit; + end; + end; + Result := -1; +end; + +function TCustomIniFile.LoadFromFile(const FileName: string): Boolean; +begin + Result := FStrings.LoadFromFile(FileName); +end; + +function TCustomIniFile.NextEmptyLineIndex(const Section: string): Integer; +begin + Result := SectionIndex(Section); + if Result > -1 then + Result := NextEmptyLineIndex(Result + 1); +end; + +function TCustomIniFile.NextEmptyLineIndex(const StartIndex: Integer): Integer; +var + i: Integer; +begin + for i := StartIndex to FStrings.Count - 1 do + begin + if Trim(FStrings[i]) = '' then + begin + FStrings[i] := ''; + Result := i; + if SectionFound(i + 1) then + FStrings.Insert(i + 1, ''); + Exit; + end; + if SectionFound(i) then + begin + FStrings.Insert(i, ''); + FStrings.Insert(i, ''); + Result := i; + Exit; + end; + end; + FStrings.Add(''); + Result := FStrings.Count - 1; +end; + +function TCustomIniFile.ReadKeys(const Section: string; const Lines: TCustomStrings): Boolean; +var + i, n: Integer; +begin + Lines.Clear; + i := SectionIndex(Section); + if i > -1 then + for n := i + 1 to FStrings.Count - 1 do + begin + if SectionFound(n) then + Break; + if Pos('=', FStrings[n]) > 0 then + Lines.Add(ReadPart(n, 1)); + end; + Result := Lines.Count > 0; +end; + +function TCustomIniFile.ReadLine(const Section: string; const Index: Integer): string; +var + i: Integer; +begin + i := SectionIndex(Section); + if i > -1 then + Result := FStrings[i + Index + 1] + else + Result := ''; +end; + +function TCustomIniFile.ReadPart(const LineIndex, PartIndex: Integer): string; +begin + Result := JMC_Parts.ReadPart(FStrings[LineIndex], PartIndex, '='); +end; + +function TCustomIniFile.ReadLines(const Section: string; const Lines: TCustomStrings; const SkipBlanks, TrimSpaces, AllowEmpty: Boolean): Boolean; +var + i, n: Integer; + function NextLineIsSection: Boolean; + begin + Result := False; + if n < FStrings.Count - 1 then + if Length(Trim(FStrings[n + 1])) > 1 then + if Trim(FStrings[n + 1])[1] = '[' then + Result := True; + end; +begin + Result := False; + Lines.Clear; + i := SectionIndex(Section); + if i < 0 then + Exit; + for n := i + 1 to FStrings.Count - 1 do + begin + if SectionFound(n) then + Break; + if (SkipBlanks and (Trim(FStrings[n]) <> '')) or ((not SkipBlanks) and (not NextLineIsSection)) then + if TrimSpaces then + Lines.Add(Trim(FStrings[n])) + else + Lines.Add(FStrings[n]); + end; + Result := (Lines.Count > 0) or AllowEmpty; +end; + +function TCustomIniFile.ReadSections(const Lines: TCustomStrings): Boolean; +var + i: Integer; +begin + Lines.Clear; + for i := 0 to FStrings.Count - 1 do + if SectionFound(i) then + Lines.Add(JMC_Parts.ReadPart(JMC_Parts.ReadPart(FStrings[i], 2, '['), 1, ']')); + Result := Lines.Count > 0; +end; + +function TCustomIniFile.ReadValue(const Section, Key: string): string; +var + i: Integer; +begin + i := KeyIndex(Section, Key); + if i > -1 then + Result := ReadPart(i, 2) + else + Result := ''; +end; + +function TCustomIniFile.ReadValues(const Section: string; const Lines: TCustomStrings): Boolean; +var + i, n: Integer; +begin + Lines.Clear; + i := SectionIndex(Section); + if i > -1 then + for n := i to FStrings.Count - 1 do + begin + if SectionFound(n) then + Break; + if Pos('=', FStrings[n]) > 0 then + Lines.Add(ReadPart(n, 2)); + end; + Result := Lines.Count > 0; +end; + +function TCustomIniFile.RenameKey(const Section, OldKey, NewKey: string): Boolean; +var + i: Integer; +begin + i := KeyIndex(Section, OldKey); + Result := i > -1; + if Result then + Result := WritePart(NewKey, i, 1); +end; + +function TCustomIniFile.RenameSection(const OldSection, NewSection: string): Boolean; +var + i: Integer; +begin + i := SectionIndex(OldSection); + Result := i > -1; + if Result then + FStrings[i] := '[' + NewSection + ']'; +end; + +function TCustomIniFile.SaveToFile(const FileName: string): Boolean; +begin + Result := FStrings.SaveToFile(FileName); +end; + +function TCustomIniFile.SectionExists(const Section: string): Boolean; +begin + Result := SectionIndex(Section) <> -1; +end; + +function TCustomIniFile.SectionIndex(const Section: string): Integer; +var + i: Integer; +begin + for i := 0 to FStrings.Count - 1 do + if UpperCase(Trim(FStrings[i])) = '[' + UpperCase(Section) + ']' then + begin + Result := i; + Exit; + end; + Result := -1; +end; + +function TCustomIniFile.SectionFound(const LineIndex: Integer): Boolean; +begin + Result := TrimLeft(Copy(FStrings[LineIndex], 1, 1)) = '['; +end; + +procedure TCustomIniFile.SetStrings(const Value: TCustomStrings); +begin + FStrings := Value; +end; + +procedure TCustomIniFile.WriteLine(const Section, NewLine: string); +var + i: Integer; +begin + i := SectionIndex(Section); + if i > -1 then + FStrings[NextEmptyLineIndex(i + 1)] := NewLine + else + if Section <> '' then + begin + if Trim(FStrings[FStrings.Count - 1]) <> '' then + FStrings.Add(''); + FStrings.Add('[' + Section + ']'); + FStrings.Add(NewLine); + end; +end; + +procedure TCustomIniFile.WriteLines(const Section: string; const Lines: TCustomStrings); +var + n, i: Integer; +begin + i := SectionIndex(Section); + if i > -1 then + begin + n := NextEmptyLineIndex(i + 1); + for i := 0 to Lines.Count - 1 do + FStrings.Insert(n + i, Lines[i]); + end + else + if Section <> '' then + begin + if Trim(FStrings[FStrings.Count - 1]) <> '' then + FStrings.Add(''); + FStrings.Add('[' + Section + ']'); + for i := 0 to Lines.Count - 1 do + FStrings.Add(Lines[i]); + end; +end; + +function TCustomIniFile.WritePart(const Part: string; const LineIndex, PartIndex: Integer): Boolean; +var + S: string; +begin + S := FStrings[LineIndex]; + Result := JMC_Parts.WritePart(S, Part, PartIndex, '='); + if Result then + FStrings[LineIndex] := S; +end; + +function TCustomIniFile.WriteSection(const Section: string): Boolean; +var + i: Integer; +begin + Result := False; + if Section = '' then + Exit; + i := SectionIndex(Section); + if i > -1 then + Exit; + if Trim(FStrings[FStrings.Count - 1]) <> '' then + FStrings.Add(''); + FStrings.Add('[' + Section + ']'); + Result := True; +end; + +function TCustomIniFile.WriteValue(const Section, Key, Value: string): Boolean; +var + i: Integer; +begin + i := KeyIndex(Section, Key); + if i > -1 then + begin + Result := WritePart(Value, i, 2); + Exit; + end; + if Key <> '' then + begin + i := NextEmptyLineIndex(Section); + if i > -1 then + begin + FStrings[i] := Key + '=' + Value; + Result := True; + Exit; + end; + if Section <> '' then + begin + if Trim(FStrings[FStrings.Count - 1]) <> '' then + FStrings.Add(''); + FStrings.Add('[' + Section + ']'); + FStrings.Add(Key + '=' + Value); + Result := True; + Exit; + end; + end; + Result := False; +end; + +{ TStoredIniFile } + +constructor TStoredIniFile.Create; +begin + inherited; + FStrings := TStringArray.Create; +end; + +destructor TStoredIniFile.Destroy; +begin + FStrings.Free; + inherited; +end; + +end. diff --git a/delphi/lib/JMC_SysUtils.pas b/delphi/lib/JMC_SysUtils.pas new file mode 100644 index 0000000..a875e2c --- /dev/null +++ b/delphi/lib/JMC_SysUtils.pas @@ -0,0 +1,45 @@ +unit JMC_SysUtils; + +interface + +uses + Windows, + SysUtils, + Classes, + Graphics; + +function DoubleToByteString(const Value: Double): string; +function ByteStringToDouble(const Value: string): Double; + +implementation + +function DoubleToByteString(const Value: Double): string; +var + Buffer: array[0..7] of Char; + i: Integer; +begin + FillChar(Buffer, 8, 0); + Move(Value, Buffer, 8); + Result := ''; + for i := 0 to 7 do + Result := Result + Buffer[i]; +end; + +function ByteStringToDouble(const Value: string): Double; +var + Buffer: array[0..7] of Char; + m: Double; + i: Integer; +begin + if Length(Value) = 8 then + begin + for i := 0 to 7 do + Buffer[i] := Value[i + 1]; + Move(Buffer, m, 8); + Result := m; + end + else + Result := 0; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_Utils.pas b/delphi/lib/JMC_Utils.pas new file mode 100644 index 0000000..298b58f --- /dev/null +++ b/delphi/lib/JMC_Utils.pas @@ -0,0 +1,370 @@ +unit JMC_Utils; + +interface + +uses + SysUtils, + JMC_Strings, + Windows, + JMC_Parts, + Graphics, + Registry, + ExtCtrls; + +function StrToCurrencyDefault(const S: string; const Default: Currency = 0): Currency; +function RemoveDollars(const Value: string): string; +function RemoveCommas(const Value: string): string; +function RemoveCharacter(const Value: string; const Character: Char): string; +function GetLoggedInUserName: string; +function PosStart(var S: string; const Sub: string; const Start: Integer): Integer; +function HandledStrToDateTime(const S: string; var Value: TDateTime): Boolean; +function StrToIntTest(const S: string; var Value: Integer): Boolean; +function StrToIntDefault(const S: string; const Default: Integer = 0): Integer; +function StrToFloatTest(const S: string; var Value: Double): Boolean; +function StrToFloatDefault(const S: string; const Default: Double = 0): Double; +function MessyStrToInt(const S: string; const Default: Integer = 0): Integer; +procedure ReadColor(const Settings: TCustomIniFile; const Section, Key: string; const Default: TColor; var Value: TColor); +procedure WriteColor(const Settings: TCustomIniFile; const Section, Key: string; const Value: TColor); +function ReadDouble(const Settings: TCustomIniFile; const Section, Key: string; const Default: Double; var Value: Double): Boolean; +procedure WriteDouble(const Settings: TCustomIniFile; const Section, Key: string; const Value: Double); +function ReadInteger(const Settings: TCustomIniFile; const Section, Key: string; const Default: Integer; var Value: Integer): Boolean; +procedure WriteInteger(const Settings: TCustomIniFile; const Section, Key: string; const Value: Integer); +//function ReadString(const Settings: TCustomIniFile; const Section, Default: string; const Value: TLabeledEdit): Boolean; overload; +function ReadString(const Settings: TCustomIniFile; const Section, Key, Default: string; var Value: string): Boolean; overload; +procedure WriteString(const Settings: TCustomIniFile; const Section, Key, Value: string); +function FloatToString(const Value: Double; const Commas: Boolean = True; const DecimalPrecision: Integer = -1; const TrimRightZeros: Boolean = True; const Width: Integer = -1): string; +function RemoveCtrlChars(const S: string): string; +function IsInteger(const Value: Double): Boolean; + +implementation + +function StrToCurrencyDefault(const S: string; const Default: Currency = 0): Currency; +var + SS: string; +begin + SS := RemoveDollars(RemoveCommas(Trim(S))); + if SS = '' then + begin + Result := Default; + Exit; + end; + try + Result := StrToCurr(SS); + except + Result := Default; + end; +end; + +function RemoveDollars(const Value: string): string; +begin + Result := RemoveCharacter(Value, '$'); +end; + +function RemoveCommas(const Value: string): string; +begin + Result := RemoveCharacter(Value, ','); +end; + +function RemoveCharacter(const Value: string; const Character: Char): string; +var + i: Integer; +begin + Result := ''; + for i := 1 to Length(Value) do + if Value[i] <> Character then + Result := Result + Value[i]; +end; + +function GetLoggedInUserName: string; +var + Reg: TRegistry; +begin + Result := ''; + Reg := TRegistry.Create; + try + Reg.RootKey := HKEY_CURRENT_USER; + Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer', False); + Result := Reg.ReadString('Logon User Name'); + finally + Reg.Free; + end; +end; + +function PosStart(var S: string; const Sub: string; const Start: Integer): Integer; +begin + Result := Pos(Sub, Copy(S, Start, Length(S) - Start + 1)); + if Result > 0 then + Result := Result + Start - 1; +end; + +function HandledStrToDateTime(const S: string; var Value: TDateTime): Boolean; +var + SS: string; +begin + Result := False; + SS := RemoveCommas(Trim(S)); + if SS = '' then + Exit; + try + Value := StrToFloat(SS); + except + Exit; + end; + Result := True; +end; + +function StrToIntTest(const S: string; var Value: Integer): Boolean; +var + SS: string; +begin + Result := False; + SS := RemoveCommas(Trim(S)); + if SS = '' then + Exit; + try + Value := StrToInt(SS); + except + Exit; + end; + Result := True; +end; + +function StrToIntDefault(const S: string; const Default: Integer = 0): Integer; +var + SS: string; +begin + SS := RemoveCommas(Trim(S)); + if SS = '' then + begin + Result := Default; + Exit; + end; + try + Result := StrToInt(SS); + except + Result := Default; + end; +end; + +function StrToFloatTest(const S: string; var Value: Double): Boolean; +var + SS: string; +begin + Result := False; + SS := RemoveCommas(Trim(S)); + if SS = '' then + Exit; + try + Value := StrToFloat(SS); + except + Exit; + end; + Result := True; +end; + +function StrToFloatDefault(const S: string; const Default: Double = 0): Double; +var + SS: string; +begin + SS := RemoveCommas(Trim(S)); + if SS = '' then + begin + Result := Default; + Exit; + end; + try + Result := StrToFloat(SS); + except + Result := Default; + end; +end; + +function MessyStrToInt(const S: string; const Default: Integer = 0): Integer; +var + Numbers: string; + b: Boolean; + i: Integer; +begin + Numbers := ''; + b := False; + for i := 1 to Length(S) do + case Ord(S[i]) of + 48..57: + begin + Numbers := Numbers + S[i]; + b := True; + end; + else + if b then + Break; + end; + if Numbers <> '' then + try + Result := StrToInt(Numbers); + Exit; + except + end; + Result := Default; +end; + +procedure ReadColor(const Settings: TCustomIniFile; const Section, Key: string; const Default: TColor; var Value: TColor); +var + S: string; + R, G, B: Byte; +begin + Value := Default; + S := Settings.ReadValue(Section, Key); + try + R := StrToInt(ReadPart(S, 1, ',')); + G := StrToInt(ReadPart(S, 2, ',')); + B := StrToInt(ReadPart(S, 3, ',')); + Value := RGB(R, G, B); + except + end; +end; + +procedure WriteColor(const Settings: TCustomIniFile; const Section, Key: string; const Value: TColor); +begin + Settings.WriteValue(Section, Key, Format('%d,%d,%d', [GetRValue(Value), GetGValue(Value), GetBValue(Value)])); +end; + +function ReadDouble(const Settings: TCustomIniFile; const Section, Key: string; const Default: Double; var Value: Double): Boolean; +begin + Value := Default; + Result := StrToFloatTest(Settings.ReadValue(Section, Key), Value); +end; + +procedure WriteDouble(const Settings: TCustomIniFile; const Section, Key: string; const Value: Double); +begin + Settings.WriteValue(Section, Key, FloatToString(Value)); +end; + +function ReadInteger(const Settings: TCustomIniFile; const Section, Key: string; const Default: Integer; var Value: Integer): Boolean; +begin + Result := StrToIntTest(Settings.ReadValue(Section, Key), Value); + if not Result then + Value := Default; +end; + +procedure WriteInteger(const Settings: TCustomIniFile; const Section, Key: string; const Value: Integer); +begin + Settings.WriteValue(Section, Key, IntToStr(Value)); +end; + +{function ReadString(const Settings: TCustomIniFile; const Section, Default: string; const Value: TLabeledEdit): Boolean; +var + S: string; +begin + S := Settings.ReadValue(Section, Value.EditLabel.Caption); + Result := S <> ''; + if Result then + Value.Text := S + else + Value.Text := Default; +end;} + +function ReadString(const Settings: TCustomIniFile; const Section, Key, Default: string; var Value: string): Boolean; +begin + Value := Settings.ReadValue(Section, Key); + Result := Value <> ''; + if not Result then + Value := Default; +end; + +procedure WriteString(const Settings: TCustomIniFile; const Section, Key, Value: string); +begin + Settings.WriteValue(Section, Key, Value); +end; + +function FloatToString(const Value: Double; const Commas: Boolean = True; const DecimalPrecision: Integer = -1; const TrimRightZeros: Boolean = True; const Width: Integer = -1): string; +var + i: Integer; + j: Integer; + C: Char; + W: string; +const + MAXDECIMALPRECISION = 10; +begin + if Commas then + C := 'n' + else + C := 'f'; + if (DecimalPrecision >= 0) and (DecimalPrecision <= MAXDECIMALPRECISION) then + begin + if Width >= DecimalPrecision then + W := SysUtils.IntToStr(Width) + else + W := ''; + Result := Format('%' + W + '.' + IntToStr(DecimalPrecision) + C, [Value]); + end + else + Result := Format('%.' + IntToStr(MAXDECIMALPRECISION) + C, [Value]); + i := Length(Result); + if TrimRightZeros and (i > 0) then + begin + j := Pos('.', Result); + if j > 0 then + repeat + if Result[i] = '0' then + Result := Copy(Result, 1, i - 1) + else + begin + if Result[i] = '.' then + Result := Copy(Result, 1, i - 1); + Break; + end; + Dec(i); + until i < j; + end; + if Length(Result) < Width then + Result := StringOfChar(' ', Width - Length(Result)) + Result; +end; + +function RemoveCtrlChars(const S: string): string; +var + i: Integer; +begin + Result := ''; + for i := 1 to Length(S) do + case Ord(S[i]) of + 32..126: Result := Result + S[i]; + end; +end; + +function IsInteger(const Value: Double): Boolean; +var + S: string; + i: Integer; + j: Integer; +begin + try + S := SysUtils.Format('%.6f', [Value]); + except + Result := False; + Exit; + end; + S := Trim(S); + if S = '' then + begin + Result := False; + Exit; + end; + for i := 1 to Length(S) do + case S[i] of + '0'..'9', '.', '-': Continue; + else + Result := False; + Exit; + end; + Result := True; + j := Pos('.', S); + for i := j + 1 to Length(S) do + case S[i] of + '0': Continue; + else + Result := False; + Exit; + end; +end; + +end. \ No newline at end of file diff --git a/delphi/lib/JMC_WinAPI.pas b/delphi/lib/JMC_WinAPI.pas new file mode 100644 index 0000000..a31865c --- /dev/null +++ b/delphi/lib/JMC_WinAPI.pas @@ -0,0 +1,158 @@ +unit JMC_WinAPI; + +//////////////////////////////////////////////////////////////////////////////// +// // +// Jared Crutchfield's Delphi Library // +// // +// JMC_WinAPI Library Unit // +// // +// Modified 19/01/2012 // +// // +//////////////////////////////////////////////////////////////////////////////// + +interface + +uses + SysUtils, + Windows, + Registry, + ShlObj, + Controls, + ComObj, + ActiveX, + Forms, + ShellAPI, + filectrl; + +type + TJMC_ShortcutLocation = (slDesktop, slPersonal, slPrograms, slSendTo, slStartMenu, slStartup, slTemplates); + +function BrowseDirectory(var Directory: string; const Parent: TWinControl; const Caption: string; const Root: WideString = ''; const NewFolderButton: Boolean = False): Boolean; +function CreateShortcut(const FileName: string; const ShortcutName: string; const ShortcutLocation: TJMC_ShortcutLocation; const Params: string = ''): Boolean; +function ShellOpen(const FileName: string): Boolean; + +implementation + +// Copied from "filectrl" unit. +function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall; +begin + if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then + SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpData); + result := 0; +end; + +// Based on "SelectDirectory" function in "filectrl" unit. +function BrowseDirectory(var Directory: string; const Parent: TWinControl; const Caption: string; const Root: WideString = ''; const NewFolderButton: Boolean = False): Boolean; +var + WindowList: Pointer; + BrowseInfo: TBrowseInfo; + Buffer: PChar; + OldErrorMode: Cardinal; + RootItemIDList, ItemIDList: PItemIDList; + ShellMalloc: IMalloc; + IDesktopFolder: IShellFolder; + Eaten, Flags: LongWord; +begin + Result := False; + if not DirectoryExists(Directory) then + Directory := ''; + FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); + if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then + begin + Buffer := ShellMalloc.Alloc(MAX_PATH); + try + RootItemIDList := nil; + if Root <> '' then + begin + SHGetDesktopFolder(IDesktopFolder); + IDesktopFolder.ParseDisplayName(Application.Handle, nil, POleStr(Root), Eaten, RootItemIDList, Flags); + end; + with BrowseInfo do + begin + hwndOwner := Application.Handle; + pidlRoot := RootItemIDList; + pszDisplayName := Buffer; + lpszTitle := PChar(Caption); + ulFlags := BIF_RETURNONLYFSDIRS or BIF_STATUSTEXT; + if NewFolderButton then + ulFlags := ulFlags or BIF_NEWDIALOGSTYLE; + if Directory <> '' then + begin + lpfn := SelectDirCB; + lParam := Integer(PChar(Directory)); + end; + end; + WindowList := DisableTaskWindows(0); + OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS); + try + ItemIDList := ShBrowseForFolder(BrowseInfo); + finally + SetErrorMode(OldErrorMode); + EnableTaskWindows(WindowList); + end; + Result := ItemIDList <> nil; + if Result then + begin + ShGetPathFromIDList(ItemIDList, Buffer); + ShellMalloc.Free(ItemIDList); + Directory := IncludeTrailingPathDelimiter(Buffer); + end; + finally + ShellMalloc.Free(Buffer); + end; + end; +end; + +function CreateShortcut(const FileName: string; const ShortcutName: string; const ShortcutLocation: TJMC_ShortcutLocation; const Params: string = ''): Boolean; +var + ShortcutObject: IUnknown; + ShortcutShellLink: IShellLink; + ShortcutPersistFile: IPersistFile; + WideFileName: WideString; + Registry: TRegistry; + S: string; +begin + Result := False; + if not FileExists(FileName) then + Exit; + ShortcutObject := CreateComObject(CLSID_ShellLink); + ShortcutShellLink := ShortcutObject As IShellLink; + ShortcutPersistFile := ShortcutObject As IPersistFile; + with ShortcutShellLink do + begin + SetPath(PChar(FileName)); + SetWorkingDirectory(PChar(ExtractFilePath(FileName))); + SetArguments(PChar(Params)); + end; + Registry := TRegistry.Create; + Registry.RootKey := HKEY_CURRENT_USER; + Registry.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False); + case ShortcutLocation of + slDesktop: S := Registry.ReadString('Desktop'); + slPersonal: S := Registry.ReadString('Personal'); + slPrograms: S := Registry.ReadString('Programs'); + slSendTo: S := Registry.ReadString('SendTo'); + slStartMenu: S := Registry.ReadString('Start Menu'); + slStartup: S := Registry.ReadString('Startup'); + slTemplates: S := Registry.ReadString('Templates'); + else + S := ''; + end; + Registry.Free; + S := IncludeTrailingPathDelimiter(S); + if DirectoryExists(S) then + begin + WideFileName := S + ShortcutName + '.lnk'; + ShortcutPersistFile.Save(PWChar(WideFileName), False); + Result := True; + end; +end; + +function ShellOpen(const FileName: string): Boolean; +begin + Result := SysUtils.FileExists(FileName); + if Result then + ShellAPI.ShellExecute(0, 'open', PChar(FileName), '', nil, Windows.SW_SHOWNORMAL) +end; + +end. \ No newline at end of file diff --git a/delphi/lib/Utils.pas b/delphi/lib/Utils.pas new file mode 100644 index 0000000..2d1d951 --- /dev/null +++ b/delphi/lib/Utils.pas @@ -0,0 +1,44 @@ +unit Utils; + +interface + +uses + Registry, + Windows, + SysUtils, + Classes; + +function CurrentUserName: string; +function CurrentComputerName: string; + +implementation + +function CurrentUserName: string; +var + Reg: TRegistry; +begin + Reg := TRegistry.Create; + try + Reg.RootKey := HKEY_CURRENT_USER; + Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer', False); + Result := Reg.ReadString('Logon User Name'); + finally + Reg.Free; + end; +end; + +function CurrentComputerName: string; +var + Reg: TRegistry; +begin + Reg := TRegistry.Create; + try + Reg.RootKey := HKEY_LOCAL_MACHINE; + Reg.OpenKey('\SYSTEM\ControlSet001\Control\ComputerName\ActiveComputerName', False); + Result := Reg.ReadString('ComputerName'); + finally + Reg.Free; + end; +end; + +end. \ No newline at end of file