DJJD's Code Sharing 2

[djjd47130]

Just as Glenn9999 posted a collection of his tips and tricks, I'm posting some of my own...


Check if a specified file is a certain extension

function IsFileType(const Filename, Extension: String): Bool;
begin
  Result:= (UpperCase(RightStr(Filename, Length(Extension)+1)) = '.'+UpperCase(Extension));
end;

Check if a specified service is installed (by service name, not image path)

function GetServiceInstalled(ServiceName: String): Bool;
var
  Reg: TRegistry;
begin
  Reg:= TRegistry.Create(RegAccess);
  try
    Reg.RootKey:= RegRoot;
    Result:= Reg.KeyExists(RegSvcKey+ServiceName);
  finally
    Reg.Free;
  end;
end;

Get the full path to a specified service (by service name)

function GetServicePath(ServiceName: String): String;
var
  Reg: TRegistry;
begin
  Reg:= TRegistry.Create(RegAccess);
  try
    Reg.RootKey:= RegRoot;
    if Reg.KeyExists(RegSvcKey+ServiceName) then begin
      if Reg.OpenKey(RegSvcKey+ServiceName, False) then begin
        Result:= Reg.ReadString('ImagePath');
        Reg.CloseKey;
      end;
    end else begin
      Result:= '';
    end;
  finally
    Reg.Free;
  end;
end;

Check if a specified service is enabled (auto start)

function GetServiceEnabled(ServiceName: String): Bool;
var
  Reg: TRegistry;
begin
  Reg:= TRegistry.Create(RegAccess);
  try
    Reg.RootKey:= RegRoot;
    if Reg.KeyExists(RegSvcKey+ServiceName) then begin
      if Reg.OpenKey(RegSvcKey+ServiceName, False) then begin
        if Reg.ReadInteger('Start') = 4 then
          Result:= False
        else
          Result:= True;
        Reg.CloseKey;
      end;
    end else begin
      Result:= False;
    end;
  finally
    Reg.Free;
  end;
end;

Get the version string of a specified EXE

function GetFileVersion(FileName: string): string;
var 
  VerInfoSize: DWORD; 
  VerInfo: Pointer; 
  VerValueSize: DWORD; 
  VerValue: PVSFixedFileInfo; 
  Dummy: DWORD; 
begin 
  VerInfoSize := GetFileVersionInfoSize(PChar(FileName), Dummy);
  GetMem(VerInfo, VerInfoSize); 
  GetFileVersionInfo(PChar(FileName), 0, VerInfoSize, VerInfo); 
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize); 
  with VerValue^ do 
  begin 
    Result := IntToStr(dwFileVersionMS shr 16); 
    Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF); 
    Result := Result + '.' + IntToStr(dwFileVersionLS shr 16); 
    Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF); 
  end; 
  FreeMem(VerInfo, VerInfoSize); 
end;

Store database connection information with ability to get connection string
Object Structure:

uses SysUtils, StrUtils;
type
  TDatabaseInfo = class(TPersistent)
  private
    fProvider: String;
    fServer: String;
    fDatabase: String;
    fLogin: String;
    fPassword: String;
    function GetConnectionString: String;
    procedure SetConnectionString(Value: String);
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Provider: String read fProvider write fProvider;
    property Server: String read fServer write fServer;
    property Database: String read fDatabase write fDatabase;
    property Login: String read fLogin write fLogin;
    property Password: String read fPassword write fPassword;
    property ConnectionString: String read GetConnectionString write SetConnectionString;
  end;

Object Implementation

constructor TDatabaseInfo.Create;
begin
  fProvider:= 'SQLOLEDB.1';
  fLogin:= 'sa';
  fServer:= '(local);
  fDatabase:= 'master';
  fPassword:= '';
end;
destructor TDatabaseInfo.Destroy;
begin
  //Nothing to free
  inherited Destroy;
end;
function TDatabaseInfo.GetConnectionString: String;
begin
  if fProvider = '' then fProvider:= 'SQLOLEDB.1';
  Result:= 'Persist Security Info=True'+
    ';Provider='+fProvider+
    ';Data Source='+fServer+
    ';Initial Catalog='+fDatabase+
    ';User ID='+fLogin+
    ';Password='+fPassword;
end;
procedure TDatabaseInfo.SetConnectionString(Value: String);
var
  Str, T, N: String;
begin
  Str:= Value;
  if RightStr(Str, 1) <> ';' then Str:= Str + ';';
  while Length(Str) > 0 do begin
    T:= Copy(Str, 1, pos(';', Str)-1);
    Delete(Str, 1, pos(';', Str));
    N:= LowerCase(Copy(T, 1, pos('=', T)-1));
    Delete(T, 1, pos('=', T));
    if N = 'provider' then fProvider:= T
    else if N = 'data source' then fServer:= T
    else if N = 'initial catalog' then fDatabase:= T
    else if N = 'user id' then fLogin:= T
    else if N = 'password' then fPassword:= T;
  end;
end;

Final Implementation:

var 
  DBInfo: TDatabaseInfo;
  ConnectionString: String;
begin
  DBInfo:= TDatabaseInfo.Create;
  Q:= TADOQuery.Create(nil);
  try
    DBInfo.Provider:= 'SQLNCLI';
    DBInfo.Server:= '192.168.4.109';
    DBInfo.Database:= 'MyDatabase';
    DBInfo.Login:= 'sa';
    DBInfo.Password:= 'MyPassword';
    ConnectionString:= DBInfo.ConnectionString;
  finally
    DDBInfo.Free;
  end;
end;

Execute a SQL script, hide console window, and read result file
This is helpful when installing updates for software that uses a database
Some code is specific to my needs
This could use some cleaning and simplifying

const
  UR_OK = 0;
  UR_ABORTED = 1;
  UR_MINOR_ERROR = 2;
  UR_MAJOR_ERROR = 3;

//Directory: Where to run from
//SqlFile: SQL Script File to be executed (including path)
//DB: Database Information (Previous example)
//AHandle: Window Handle
//Results: Pre-created TStringList to save results to
//  Result: Severity of error(s)

function ExecOSQL(Directory, SqlFile: string; DB: TDatabaseInfo;
  AHandle: HWND; Results: TStringList): smallInt;
const
  ResultFile = '_Results.txt';
var
  Dir: String;
  lst: TStringList;
  s: string;
  AppHAND, NextHandle: HWND;
  NextTitle: array[0..260] of char;
  x, y: smallInt;
  z: integer;
begin
  Dir:= Directory;
  if RightStr(Dir, 1) <> '\' then Dir:= Dir + '\';
  Result:= UR_OK;
  //if CopyFile(PChar(SQLFile), PChar(Dir+ExtractFileName(SqlFile)), False) then begin
  if FileExists(SqlFile) then begin
    s:=' -U'+DB.Login+' -P'+DB.Password+' -d'+DB.Database+' -S'+DB.Server+
      ' -i'+SqlFile+' -o'+ResultFile;
    if assigned(Results) then Results.Clear;
    if Uppercase(DB.Database) <> 'RUGMSSQL' then begin
      lst:= TstringList.Create;
      try
        lst.LoadFromFile(Dir+SqlFile);
        if lst.Count > 15 then y:= 15 else y:= lst.Count - 1;
        for x:= 0 to y do begin
          if pos('USE RUGMSSQL', Uppercase(lst[x])) > 0 then begin
            lst[x]:= 'USE '+DB.Database;
            lst.SaveToFile(sqlFile);
            Break;
          end;
        end;
      finally
        lst.Free;
      end;
    end;
    AppHand:= ShellExecute(AHandle, nil, 'osql.exe',
      PChar(s), PChar(Dir), SW_HIDE);
    if AppHand > 32 then
    begin
      Sleep(1000);
      AppHAND:= 0;
      NextHandle:= GetWindow(AHandle, GW_HWNDFIRST);
      while NextHandle > 0 do begin
        GetWindowText(NextHandle, NextTitle, 255);
        if pos('\osql.exe', StrPas(NextTitle)) > 0 then begin
          AppHAND:= NextHandle;
          NextHandle:= 0;
        end else
          NextHandle := GetWindow(NextHandle, GW_HWNDNEXT);  // Get the next window
      end;
      x:= 0;
      if AppHAND > 0 then begin      //no more then 200 sec
        while (IsWindow(AppHAND))and(x < 150) do begin //wait for the window to close
          inc(x);
          Sleep(1000);
        end;
      end else begin
        for z:= 1 to 5 do begin
          sleep(1000);
        end;
      end;
      if FileExists(Dir+ResultFile) then begin
        lst:= TstringList.Create;
        try
          try
            lst.LoadFromFile(Dir+ResultFile);
            for x:= 0 to lst.count - 1 do begin
              if (lst[x][1]<> '<')and(not (lst[x][1] in ['0'..'9'])) then begin
                if assigned(Results) then
                  Results.Append('OSQL Result: '+lst[x]);
                s:= lowercase(lst[x]);
                if
                  (pos('error', s)> 0)
                or
                  (pos('invalid column', s)> 0)
                or
                  (pos('invalid object name', s)> 0)
                or
                  (pos('invalid user', s)> 0)
                or
                  (pos('login failed', s)> 0)
                or
                  (pos('server does not exist or access denied', s)> 0)
                then
                  Result:= UR_MAJOR_ERROR;    
                if
                  (pos('invalid column', s)> 0)
                or
                  (pos('invalid object name', s)> 0)
                or
                  (pos('cannot find the object', s)> 0)
                then
                  Result:= UR_MINOR_ERROR;
              end;
            end;
          except
            on e: exception do begin
              if assigned(Results) then
                Results.Append('Error: '+e.Message);
            end;
          end;
        finally
          lst.Free;
        end;
        //DeleteFile(PChar(Dir+ResultFile));
      end
        else Result:= UR_MAJOR_ERROR;
    end;
  end else begin
    if assigned(Results) then
      Results.Append('SQL file failed to copy');
    Result:= UR_MAJOR_ERROR;
  end;
end;

Declare type which holds an array of colors which you can easily extract RGB values
This is helpful when an array of TColor is not enough, and a list of custom color objects is too much.

uses Windows;
const
  PixelCountMax = 32768;
type      
  pRGBArray = ^TRGBArray;
  TRGBArray = array[0..PixelCountMax-1] of TRGBTriple;

as opposed to not enough...

type
  TColorArray = array[0..PixelCountMax-1] of TColor;

or too much...

type
  TRGB = class(TPersistent) 
  private
    fColor: TColor;
    function GetRed: Integer;
    function GetGreen: Integer;
    function GetBlue: Integer;
    procedure SetRed(Value: Integer);
    procedure SetGreen(Value: Integer);
    procedure SetBlue(Value: Integer);
  public
    constructor Create;
  published
    property Red: Integer read GetRed write SetRed;
    property Green: Integer read GetGreen write SetGreen;
    property Blue: Integer read GetBlue write SetBlue;
    property Color: TColor read fColor write fColor;
  end;

  TRMPColors = class(TPersistent)
  private
    fList: TList;  //of TRGB
    function GetRGB(Index: Integer): TRGB;
    procedure SetRGB(Index: Integer; Value: TRGB);
    function GetCount: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    property Colors[Index: Integer]: TRGB read GetRGB write SetRGB;
    procedure Add(Color: TRGB); overload;
    procedure Add(Color: TColor); overload;
    property Count: Integer read GetCount;
  end;
//And a lot more I won't even bother to touch....

JD Solutions

 

[djjd47130]

Not tested, but here's some more...



Compare two bitmaps together to see if they're the same or not
Originally from Glenn9999 but modified for my needs
Used in Remote Desktop system to enhance refreshing performance

//Return proper byte size for bitmap comparison input
function GetPixelSize(Format: TPixelFormat): Integer;
begin
  case Format of
    pf8bit:  Result:= 1;
    pf16bit: Result:= 2;
    pf24bit: Result:= 3;
    pf32bit: Result:= 4;
  else
    Result:= 0;
  end;
end;

//Compares two lines of pixels together to see if they're the same or not
function LinesAreSame(Line1, Line2: TJDRMImageLine; Width: Integer): Boolean;
begin
  Result:= CompareMem(Line1, Line2, Width);
end;

//Compares two bitmaps together to see if they're the same or not
function BitmapsAreSame(Bitmap1, Bitmap2: TJDRMImageBlock): Boolean;
var
  X: integer;
begin
  Result:= False;
  if (Bitmap1.Width = Bitmap2.Width) and (Bitmap1.Height = Bitmap2.Height)
    and (Bitmap1.PixelFormat = Bitmap2.PixelFormat) then
  begin
    for X:= 0 to (Bitmap1.Height-1) do begin
      Result:= CompareMem(Bitmap1.AsBitmap.ScanLine[X], Bitmap2.AsBitmap.ScanLine[X],
        Bitmap1.Width * GetPixelSize(Bitmap1.PixelFormat));
      if not Result then Break;
    end;
  end;
end;

Take a screenshot of the main screen
Used for Remote Desktop System
Original code by unknown source, modified to fit my needs

function ScreenShot(DrawCursor: Boolean; Quality: TPixelFormat): TBitmap;
var
  DC: HDC;
  R: TRect;
  CursorInfo: TCursorInfo;
  Icon: TIcon;
  IconInfo: TIconInfo;
begin
  //Create bitmap result
  Result:= TBitmap.Create;
  //Get desktop handle
  DC:= GetDC(GetDesktopWindow);
  try
    //Set result to new screenshot image
    Result.Width:= GetDeviceCaps (DC, HORZRES);
    Result.Height:= GetDeviceCaps (DC, VERTRES);
    Result.PixelFormat:= Quality;
    //Actual acquiring of screenshot image
    BitBlt(Result.Canvas.Handle,
      0,
      0,
      Result.Width,
      Result.Height,
      DC,
      0,
      0,
      SRCCOPY);
  finally
    ReleaseDC(GetDesktopWindow, DC);
  end;
  //Draw cursor
  if DrawCursor then begin
    R:= Result.Canvas.ClipRect;
    Icon:= TIcon.Create;
    try
      CursorInfo.cbSize:= SizeOf(CursorInfo);
      if GetCursorInfo(CursorInfo) then
      if CursorInfo.Flags = CURSOR_SHOWING then
      begin
        Icon.Handle:= CopyIcon(CursorInfo.hCursor);
        if GetIconInfo(Icon.Handle, IconInfo) then
        begin
          //Draw cursor image on screenshot image
          Result.Canvas.Draw(
            CursorInfo.ptScreenPos.x - Integer(IconInfo.xHotspot) - r.Left,
            CursorInfo.ptScreenPos.y - Integer(IconInfo.yHotspot) - r.Top,
            Icon);
        end;
      end;
    finally
      Icon.Free;
    end;
  end;
end;

Send/Receive through Sockets
This example demonstrates basic send/receive functionality of sockets, and not the connection methods
Global

const
  PK_DIV = ';';
  PK_END = '$>>';

const
  SVC_LOGIN = 1;
  SVC_LOGIN_PASS = 2;
  SVC_LOGIN_FAIL = 3;
  SVC_GET_SOME_INFO = 4;

function IntToStrLen(const Value, Length: Integer): String;
//Converts an Integer to a String with a given Length of characters
begin
  Result:= IntToStr(Value); //Convert the integer to a string
  Result:= Copy(Result, 1, Length); //Forcefully truncate the string
  while Length(Result) < Length do //Loop until desired length is reached
    Result:= '0'+Result; //Add '0' to beginning of result string
end;

Client Socket

procedure TfrmClient.SendLogin(Const Username, Password: String);
begin
  TClientSocket(Socket).Socket.SendText(IntToStrLen(SVC_LOGIN, 4)+
    PK_DIV+Username+PK_DIV+Password+PK_DIV+PK_END);
end;

Server Socket

var
  IsBusy: Bool; //Determines whether or not processing a packet
  fBuffer: String; //Holds all pending packet data
procedure TfrmMain.CliRead(Sender: TObject; Socket: TCustomWinSocket);
begin
  //Just add data to the end of the buffer string
  fBuffer:= fBuffer + Socket.ReceiveText;
end;
procedure TfrmMain.TmrOnTimer(Sender: TObject);
var
  Pck, T String;
  Svc: Integer;
begin
  if not IsBusy then begin
    IsBusy:= True;
    try
      if pos(PK_END, fBuffer) > 0 then begin //New packet is available
        Pck:= Copy(fBuffer, 1, pos(PK_END, fBuffer)-1); //Copy next available packet
        Delete(fBuffer, 1, pos(PK_END, fBuffer)+Length(PK_END)-1); //Delete the copied packet
        T:= Copy(Pck, 1, 4);
        Delete(Pck, 1, 5); //Delete service AND divider
        Svc:= StrToIntDef(T, 0); //Identify and convert service
        case Svc of
          SVc_LOGIN: HandleLogin(Pck);
          SVC_GET_SOME_INFO: HandleInfo(Pck);
        end;
      end;
    finally
      IsBusy:= False;
    end;
  end;
end;
procedure TfrmMain.HandleLogin(Packet: String);
var
  Pck, U, P: String;
begin
  Pck:= Packet;
  U:= Copy(Pck, 1, pos(PCK_DIV, Pck)-1);
  Delete(Pck, 1, pos(PCK_DIV, PCK));
  P:= Copy(Pck, 1, pos(PCK_DIV, Pck)-1);
  Delete(Pck, 1, pos(PCK_DIV, PCK));
  //Validate login and send back
  if ValidateLogin(U, P) then begin
    //Send approval...
  end else begin
    //Send denial...
  end;
end;
procedure TfrmMain.HandleInfo(Packet: String);
begin
  //Do something with your packet data
end;

JD Solutions

 

[djjd47130]

By the way, I created this function... Is there something pre-made that does this? It just simply converts an integer to a string (IntToStr) and returns the string with a given number of characters (Length). It's used to make sure a string representing an integer is always the same length, and can be converted back to an integer. In the above example, I use it as the Packet's Service (or command) with 4 characters.

Input:
I:= IntToStrLen(15, 4);
Output:
I = '0015'; (Prefixed with '0' to fill in empty space)

Input:
I:= IntToStrLen(1512, 3);
Output:
I = '151'; (After truncating)

function IntToStrLen(const Value, Length: Integer): String;
//Converts an Integer to a String with a given Length of characters
begin
  Result:= IntToStr(Value); //Convert the integer to a string
  Result:= Copy(Result, 1, Length); //Forcefully truncate the string
  while Length(Result) < Length do //Loop until desired length is reached
    Result:= '0'+Result; //Add '0' to beginning of result string
end;

JD Solutions

 

[whosrdaddy]

Many people forget about the format function:

function IntToStrLen(const Value, Length: Integer): String;

var len : string;

begin
 len := IntToStr(Length);
 // left pad with zeros
 Result := Format('%.'+len+'d', [Value]);
 // truncate string
 Result := Format('%.'+len+'s', [Result]);
end;

this code will be faster because format is optimized...

Cheers,
Daddy

-----------------------------------------------------
What You See Is What You Get
Never underestimate tha powah of tha google!

 

[djjd47130]

Thanks man, that's perfect.

JD Solutions

 

[whosrdaddy]

mmm, it can do even better

function IntToStrLen(const Value, Length: Integer): String;
begin
 // left pad with zeros
 Result := Format('%.*d', [Length, Value]);
 // truncate string
 Result := Format('%.*s', [Length, Result]);
end;

Cheers,
Daddy

-----------------------------------------------------
What You See Is What You Get
Never underestimate tha powah of tha google!