mischelpfunctions.pas

Gantt source file example to use in delphi 7

{-----------------------------------------------------------------------------
 Unit Name: MiscHelpFunctions
 Author:    paul fisher
 Purpose:   Misc Functions for Gantt
 History:
-----------------------------------------------------------------------------}


unit MiscHelpFunctions;

interface

Uses  windows,GanttUnit,GanttLang,Graphics,DateUtils,SysUtils;



function ItemTypeToComboString(ItemType: TGanttItemDrawStyle): string;
function ComboStringToItemType(ItemType: string): TGanttItemDrawStyle;
Function StringToItemType(ItemType : String) : TGanttItemDrawStyle;
Function ItemTypeToString(ItemType : TGanttItemDrawStyle) : String;

Function StatusTypeToString(ItemType : TGanttItemStatus) : String;
Function StringToStatusType(ItemType : String) : TGanttItemStatus;

function BrushStyleToComboString(ItemType: TBrushStyle): string;
function ComboStringToBrushStyle(ItemType: string): TBrushStyle;
Function StringToBrushStyle(ItemType : String) : TBrushStyle;
Function BrushStyleToString(ItemType : TBrushStyle) : String;

Function StringToLinkType(LinkType : String) : TGanttLinkType;
Function LinkTypeToString(LinkType : TGanttLinkType) : String;


function CreateAngledFont(Font: HFont; Angle: Longint;
  Quality: byte = PROOF_QUALITY): HFont;
procedure TextOutA(Canvas: TCanvas; X, Y, Angle: Integer;
  Text: string);

function ISMonday(GridDate: TDateTime): Boolean; overload;
function getmonday(GridDate: TDateTime): TDateTime; overload;



function GetDaysLeft(StartDate,GridStart: TDateTime; StartMonth, Days: Integer): Integer; overload;
function GetDaysLeft(StartDate, GridDate: TDateTime; Days: Integer): Integer; overload;

function CanDraw(StartDate, EndDate, GridStart: TDatetime; TimeType: TGanttTimeType): Boolean;
function GetTimeLeft(StartDate, EndDate, GridStart: TDateTime; TimeType: TGanttTimeType): Integer;
function GetTimeFromStart(StartDate, EndDate, GridStart: TDatetime; TimeType: TGanttTimeType): Integer;
function GetDaysFromStart(StartDate, GridStart: Tdatetime; StartMonth: Integer): Integer;
function SpanOfNowAndThen(const ANow, AThen: TDateTime): TDateTime;
Function GetDaysApart(const Date1,Date2 : TDateTime):Longint;
function GetDaysInTheMonth(StartDate: TDateTime; Month: Integer): Integer;
function GetNumberOfDays(StartMonth, Months: Integer): Integer;
function ISWeekend(GridDate: TDateTime): Boolean; overload;
function ISWeekend(Year, Month, Day: Integer): Boolean; overload;
function GetPixelsPerPercent(Percent, Width: Integer): Integer;

Function GetDateAsTitle(MyDate : TDateTime; FLanguage:TGanttLanguageValue) : String;
//function MinimizeString(Canvas : TCanvas; aString: string; aMaxLength: integer): string;


function StartOfISOWeek (const DT: TDateTime): TDateTime;
function EndOfISOWeek (const DT: TDateTime): TDateTime;
function ISODayOfWeek (const DT: TDateTime): Integer;
function Date2ISOWeekStr (const DT: TDateTime;weekstring: string): string;
procedure Date2ISOWeekNo (const DT: TDateTime; var WeekNo: Byte; var Year: Word);
function GetFirstDayOfYear (const Year: Word): TDateTime;
function ISOWeeksInYear (const Year: Word): Byte;

//JK Added Function
function GetFirstDayofMonth (const ADate: TDateTime): TDateTime;



implementation




Function StatusTypeToString(ItemType : TGanttItemStatus) : String;
begin
   case ItemType of
   gsNoActivity     : Result := 'gsNoActivity';
   gsWorkInProgress     : Result := 'gsWorkInProgress';
   gsBenchmark      : Result := 'gsBenchmark';
   gsHeldForResource      : Result := 'gsHeldForResource';
   gsCancelled    : Result := 'gsCancelled';
   gsDeferred : Result := 'gsDeferred';
  end;
end;


Function StringToStatusType(ItemType : String) : TGanttItemStatus;
begin
   Result := gsNoActivity;
   if ItemType = 'gsNoActivity' then Result := gsNoActivity;
   if ItemType = 'gsWorkInProgress' then Result := gsWorkInProgress;
   if ItemType = 'gsBenchmark' then Result := gsBenchmark;
   if ItemType = 'gsHeldForResource' then Result := gsHeldForResource;
   if ItemType = 'gsCancelled' then Result := gsCancelled;
   if ItemType = 'gsDeferred' then Result := gsDeferred;
end;






Function ItemTypeToString(ItemType : TGanttItemDrawStyle) : String;
begin
   case ItemType of
   dsBlock     : Result := 'dsBlock';
   dsArrow     : Result := 'dsArrow';
   dsBall      : Result := 'dsBall';
   dsRing      : Result := 'dsRing';
   dsFinish    : Result := 'dsFinish';
   dsBenchMark : Result := 'dsBenchMark';
   dsEnd       : Result := 'dsEnd';
   dsDiaGroup  : Result := 'dsDiaGroup';
   dsPointGroup  : Result := 'dsPointGroup';
   dsShardGroup  : Result := 'dsShardGroup';
  end;
end;

Function StringToItemType(ItemType : String) : TGanttItemDrawStyle;
begin
   Result := dsBlock;
   if ItemType = 'dsBlock' then Result := dsBlock;
   if ItemType = 'dsArrow' then Result := dsArrow;
   if ItemType = 'dsBall' then Result := dsBall;
   if ItemType = 'dsRing' then Result := dsRing;
   if ItemType = 'dsFinish' then Result := dsFinish;
   if ItemType = 'dsBenchMark' then Result := dsBenchMark;
   if ItemType = 'dsEnd' then Result := dsEnd;
   if ItemType = 'dsDiaGroup' then Result := dsDiaGroup;
   if ItemType = 'dsPointGroup' then Result := dsPointGroup;
   if ItemType = 'dsShardGroup' then Result := dsShardGroup;
end;



Function BrushStyleToString(ItemType : TBrushStyle) : String;
begin
   case ItemType of
   bsSolid     : Result := 'bsSolid';
   bsClear     : Result := 'bsClear';
   bsHorizontal      : Result := 'bsHorizontal';
   bsVertical      : Result := 'bsVertical';
   bsFDiagonal    : Result := 'bsFDiagonal';
   bsBDiagonal : Result := 'bsBDiagonal';
   bsCross : Result := 'bsCross';
   bsDiagCross : Result := 'bsDiagCross';
  end;
end;


Function StringToBrushStyle(ItemType : String) : TBrushStyle;
begin
   Result := bsClear;
   if ItemType = 'bsSolid' then Result := bsSolid;
   if ItemType = 'bsClear' then Result := bsClear;
   if ItemType = 'bsHorizontal' then Result := bsHorizontal;
   if ItemType = 'bsVertical' then Result := bsVertical;
   if ItemType = 'bsFDiagonal' then Result := bsFDiagonal;
   if ItemType = 'bsBDiagonal' then Result := bsBDiagonal;
   if ItemType = 'bsCross' then Result := bsCross;
   if ItemType = 'bsDiagCross' then Result := bsDiagCross;
end;




function ItemTypeToComboString(ItemType: TGanttItemDrawStyle): string;
begin
   case ItemType of
      dsBlock: Result := 'Block';
      dsArrow: Result := 'Arrow';
      dsBall: Result := 'Ball';
      dsRing: Result := 'Ring';
      dsFinish: Result := 'Finish';
      dsBenchMark: Result := 'BenchMark';
      dsEnd      : Result := 'End';
      dsDiaGroup  : Result := 'Diamond Group';
      dsPointGroup  : Result := 'Point Group';
      dsShardGroup  : Result := 'Shard Group';
   end;
end;



function ComboStringToItemType(ItemType: string): TGanttItemDrawStyle;
begin
   Result := dsBlock;
   if ItemType = 'Block' then Result := dsBlock;
   if ItemType = 'Arrow' then Result := dsArrow;
   if ItemType = 'Ball' then Result := dsBall;
   if ItemType = 'Ring' then Result := dsRing;
   if ItemType = 'Finish' then Result := dsFinish;
   if ItemType = 'BenchMark' then Result := dsBenchMark;
   if ItemType = 'End' then Result := dsEnd;
   if ItemType = 'Diamond Group' then Result := dsDiaGroup;
   if ItemType = 'Point Group' then Result := dsPointGroup;
   if ItemType = 'Shard Group' then Result := dsShardGroup;
end;



function BrushStyleToComboString(ItemType: TBrushStyle): string;
begin
   case ItemType of
      bsSolid: Result := 'Solid';
      bsClear: Result := 'Clear';
      bsHorizontal: Result := 'Horizontal';
      bsVertical: Result := 'Vertical';
      bsFDiagonal: Result := 'FDiagonal';
      bsBDiagonal: Result := 'BDiagonal';
      bsCross: Result := 'Cross';
      bsDiagCross: Result := 'DiagCross';
   end;
end;


function ComboStringToBrushStyle(ItemType: string): TBrushStyle;
begin
   Result := bsClear;
   if ItemType = 'Solid' then Result := bsSolid;
   if ItemType = 'Clear' then Result := bsClear;
   if ItemType = 'Horizontal' then Result := bsHorizontal;
   if ItemType = 'Vertical' then Result := bsVertical;
   if ItemType = 'FDiagonal' then Result := bsFDiagonal;
   if ItemType = 'BDiagonal' then Result := bsBDiagonal;
   if ItemType = 'Cross' then Result := bsCross;
   if ItemType = 'DiagCross' then Result := bsDiagCross;
end;


Function LinkTypeToString(LinkType : TGanttLinkType) : String;
begin
   case LinkType of
   lsFinishStart     : Result := 'lsFinishStart';
   lsStartFinish     : Result := 'lsStartFinish';
   lsStartStart      : Result := 'lsStartStart';
   lsFinishFinish     : Result := 'lsFinishFinish';
  end;
end;


Function StringToLinkType(LinkType : String) : TGanttLinkType;
begin
   Result := lsFinishStart;
   if LinkType = 'lsFinishStart'  then Result := lsFinishStart;
   if LinkType = 'lsStartFinish'  then Result := lsStartFinish;
   if LinkType = 'lsStartStart'   then Result := lsStartStart;
   if LinkType = 'lsFinishFinish' then Result := lsFinishFinish;
end;






function CreateAngledFont(Font: HFont; Angle: Longint;
  Quality: byte): HFont;
var
  FontInfo: TLogFontA;    // Font information structure
begin
  // Get the information of the font passed as parameter
  if GetObject(Font, SizeOf(FontInfo), @FontInfo) = 0 then begin
    Result := 0;
    exit;
  end;
  // Set the angle
  FontInfo.lfEscapement := Angle;
  FontInfo.lfOrientation := Angle;
  // Set the quality
  FontInfo.lfQuality := Quality;
  // Create a new font with the modified information
  // The new font must be released calling DeleteObject
  Result := CreateFontIndirect(FontInfo);
end;



procedure TextOutA(Canvas: TCanvas; X, Y, Angle: Integer;
  Text: string);
var
  OriginalFont, AngledFont: HFont;
begin
  // Create an angled font from the current font
  AngledFont := CreateAngledFont(Canvas.Font.Handle, Angle);
  if AngledFont <> 0 then begin
    // Set it temporarily as the current font
    OriginalFont := SelectObject(Canvas.Handle, AngledFont);
    if OriginalFont <> 0 then begin
      // Write the text
      Canvas.TextOut(X, Y, Text);
      // Restore the original font
      if SelectObject(Canvas.Handle, OriginalFont) = 0 then begin
        Canvas.Font.Handle := AngledFont;
        // raise Exception.Create('Couldn''t restore font');
        exit;
      end;
    end;
    // Release the angled font
    DeleteObject(AngledFont)
  end;
end;




function GetPixelsPerPercent(Percent, Width: Integer): Integer;
begin
   Result := Trunc((Width / 100) * Percent);
end;


function ISWeekend(Year, Month, Day: Integer): Boolean; overload;
var
   DayConst: Integer;
begin
   DayConst := DayOfTheWeek(EncodeDate(Year, Month, Day));
   case DayConst of
      6: Result := True;
      7: Result := True;
   else
      Result := False;
   end;
end;


function ISWeekend(GridDate: TDateTime): Boolean; overload;
var
   DayConst: Integer;
begin
   DayConst := DayOfTheWeek(GridDate);
   case DayConst of
      6: Result := True;
      7: Result := True;
   else
      Result := False;
   end;
end;


function ISMonday(GridDate: TDateTime): Boolean; overload;

begin
   if  DayOfTheWeek(GridDate) = 1  then
       Result := True
   else
      Result := False;
end;


function getmonday(GridDate: TDateTime): TDateTime; overload;
var
 doit : boolean;
begin
   if ISMonday(GridDate) then doit:=false
   else    doit:=true;

   while doit do
   begin
    GridDate := GridDate - 1;
    if ISMonday(GridDate) then doit:=false;
   end;
   result:=GridDate;
end;


{Function GetNumberOfDays(StartDate, EndDate : TDateTime) : Integer;
begin
  Result := DaysBetween(StartDate,EndDate);
end; }


function GetNumberOfDays(StartMonth, Months: Integer): Integer;
var
   StartDate, Enddate: TDateTime;
   AddedYear, NewMonth : Integer;
begin
   StartDate := EncodeDate(YearOf(Now), StartMonth, 1);

   AddedYear := 0;   // Fix for month overflow Cagatay Tengiz
   NewMonth := StartMonth + Months;
   if (Months + StartMonth) > 12 then
   begin
     AddedYear := (Months + StartMonth) div 12;
     NewMonth := (Months + StartMonth) Mod 12;
   end;

   Enddate := EncodeDateTime(YearOf(Now) + AddedYear, NewMonth, 1, 0, 0, 0, 0);