ivclcomponent.pas

iocopm3.04源码,一套很好的工控开发工具

function TiVCLComponent.GetBytesPNG(Compression: Integer): OleVariant;
var
  PNGObject     : TPNGObject;
  Bitmap        : TBitmap;
  MemoryStream  : TMemoryStream;
  P             : Pointer;
  AVariant      : OleVariant;
begin
  Lock;
  try
    if (Compression < 0) or (Compression > 9) then raise Exception.Create('Compression must be in the range of 0-9');
    Bitmap := TBitmap.Create;
    try
      Bitmap.Canvas.Lock;
      Bitmap.Canvas.Handle := CreateCompatibleDC(0);
      Bitmap.PixelFormat   := pf24bit;
      Bitmap.Width         := Width;
      Bitmap.Height        := Height;
      Bitmap.HandleType    := bmDIB;
      iPaintTo(Bitmap.Canvas);

      {$IFDEF EVAL}
      with Bitmap.Canvas do
        begin
          Brush.Color := clBlack;
          Font.Color  := clYellow;
          Font.Style  := [fsBold];
          Font.Size   := 10;
          TextOut(0,0, 'Iocomp Evaluation');
        end;
      {$ENDIF}

      PNGObject := TPNGObject.Create;
      try
        PNGObject.Assign(Bitmap);
        PNGObject.CompressionLevel := Compression;

        MemoryStream := TMemoryStream.Create;
        try
          PNGObject.SaveToStream(MemoryStream);

          MemoryStream.Position := 0;

          AVariant := VarArrayCreate([0, MemoryStream.Size-1], varByte);
          P := VarArrayLock(AVariant);

          MemoryStream.ReadBuffer(P^, MemoryStream.Size);
          VarArrayUnlock(AVariant);
          Result := AVariant;
        finally
          MemoryStream.Free;
        end;
      finally
        PNGObject.Free;
      end;
      Bitmap.Canvas.Unlock;
    finally
      Bitmap.Free;
    end;
  finally
    UnLock;
  end;
end;
//****************************************************************************************************************************************************
function TiVCLComponent.GetJPEG(Compression: Integer; Progressive: Boolean): TJPEGImage;
var
  JPEGImage     : TJPEGImage;
  Bitmap        : TBitmap;
begin
  if (Compression < 1) or (Compression > 100) then raise Exception.Create('Compression must be in the range of 1-100');
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width  := Width;
    Bitmap.Height := Height;
    iPaintTo(Bitmap.Canvas);

    {$IFDEF EVAL}
    with Bitmap.Canvas do
      begin
        Brush.Color := clBlack;
        Font.Color  := clYellow;
        Font.Style  := [fsBold];
        TextOut(0,0, 'Iocomp Evaluation');
      end;
    {$ENDIF}

    JPEGImage := TJPEGImage.Create;

    JPEGImage.CompressionQuality  := Compression;
    JPEGImage.Performance         := jpBestQuality;
    JPEGImage.PixelFormat         := jf24Bit;
    JPEGImage.ProgressiveEncoding := Progressive;
    JPEGImage.Assign(Bitmap);
    JPEGImage.Compress;
    Result := JPEGImage;
  finally
    Bitmap.Free;
  end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.GetThemePaths(var IocompPathName, UserPathName: String);
var
  Registry : TRegistry;
  AString  : String;
begin
  Registry := TRegistry.Create;
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;
    Registry.OpenKey('SOFTWARE\Iocomp\Themes',False);
    IocompPathName := Trim(Registry.ReadString('Iocomp Defined Theme Path'));
    UserPathName   := Trim(Registry.ReadString('User Defined Theme Path'  ));

    Registry.RootKey := HKEY_CURRENT_USER;
    Registry.OpenKey('SOFTWARE\Iocomp\Themes',False);

    AString := '';
    AString := Trim(Registry.ReadString('Iocomp Defined Theme Path'));
    if AString <> '' then IocompPathName := AString;

    AString := '';
    AString := Trim(Registry.ReadString('User Defined Theme Path'));
    if AString <> '' then UserPathName   := AString;

    if Length(IocompPathName) <> 0 then if Copy(IocompPathName, Length(IocompPathName), 1) <> '\' then IocompPathName := IocompPathName + '\';
    if Length(UserPathName  ) <> 0 then if Copy(UserPathName,   Length(UserPathName),   1) <> '\' then UserPathName   := UserPathName   + '\';
  finally
    Registry.Free;
  end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.ClearAllSchemes;
var
  AStringList : TStringList;
begin
  while FThemeCategoryList.Count <>  0 do
    begin
      AStringList := FThemeCategoryList.Objects[0] as TStringList;
      while AStringList.Count <> 0 do
        begin
          AStringList.Objects[0].Free;
          AStringList.Delete(0);
        end;
      FThemeCategoryList.Objects[0].Free;
      FThemeCategoryList.Delete(0);
    end;
end;
//****************************************************************************************************************************************************
function TiVCLComponent.GetThemeCategoryListByName(Name: String): TStringList;
var
  Index : Integer;
begin
  Index := FThemeCategoryList.IndexOf(Name);
  if Index <> -1 then
    begin
      Result := FThemeCategoryList.Objects[Index] as TStringList;
    end
  else
    begin
      Result := TStringList.Create;
      FThemeCategoryList.AddObject(Name, Result);
    end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.LoadAllThemes(FileStream: TiXMLMemoryStream; SchemeListClass: TiSchemeListClass);
var
  AString        : String;
  SchemeTypeList : TStringList;
  SchemeList     : TStringList;
  ElementName    : String;
  ElementValue   : String;
begin
  with FileStream do
    begin
      GotoElementStart('SchemeTypes');
      while PeekNextPiece = 'SchemeType' do
        begin
          GotoElementStart('SchemeType');
          AString := GetElement('Name');
          SchemeTypeList := GetThemeCategoryListByName(AString);

          while PeekNextPiece = 'Scheme' do
            begin
              GotoElementStart('Scheme');
              AString := GetElement('Name');

              SchemeList := SchemeListClass.Create;
              SchemeTypeList.AddObject(AString, SchemeList);

              GotoElementStart('Properties');
              while PeekNextPiece <> '/Properties' do
                begin
                  ElementName  := '';
                  ElementValue := '';
                  ElementName  := PeekNextPiece;
                  ElementValue := GetElement(ElementName);
                  if ElementName <> '' then SchemeList.Add(ElementName + ' = ' + ElementValue);
                end;
              if GetNextPiece <> '/Properties' then raise Exception.Create('Error Loading Scheme. XML File Malformed');
              if GetNextPiece <> '/Scheme'     then raise Exception.Create('Error Loading Scheme. XML File Malformed');
            end;

          if GetNextPiece <> '/SchemeType'     then raise Exception.Create('Error Loading Scheme. XML File Malformed');
        end;
      if GetNextPiece <> '/SchemeTypes'        then raise Exception.Create('Error Loading Scheme. XML File Malformed');
    end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.LoadThemes;
var
  FileStream     : TiXMLMemoryStream;
  IocompPathName : String;
  UserPathName   : String;
  FileName       : String;
begin
  ClearAllSchemes;
  GetThemePaths(IocompPathName, UserPathName);

  FileName := IocompPathName + ClassName + '.xml';
  if FileExists(FileName) then
    begin
      FileStream := TiXMLMemoryStream.Create;
      FileStream.LoadFromFile(FileName);
      try
        LoadAllThemes(FileStream, TiIocompSchemeList);
      finally
        FileStream.Free;
      end;
    end;

  FileName := UserPathName + ClassName + 'User.xml';
  if FileExists(FileName) then
    begin
      FileStream := TiXMLMemoryStream.Create;
      FileStream.LoadFromFile(FileName);
      try
        LoadAllThemes(FileStream, TiUserSchemeList);
      finally
        FileStream.Free;
      end;
    end;
end;
//****************************************************************************************************************************************************
function TiVCLComponent.GetThemeCategoryCount: Integer;
begin
  Result := FThemeCategoryList.Count;
end;
//****************************************************************************************************************************************************
function TiVCLComponent.GetThemeCategoryName(CategoryIndex: Integer): String;
begin
  Result := FThemeCategoryList.Strings[CategoryIndex];
end;
//****************************************************************************************************************************************************
function TiVCLComponent.GetThemeCategorySchemeCount(CategoryIndex: Integer): Integer;
begin
  Result := (FThemeCategoryList.Objects[CategoryIndex] as TStringList).Count;
end;
//****************************************************************************************************************************************************
function TiVCLComponent.GetThemeCategorySchemeName(CategoryIndex, SchemeIndex: Integer): String;
begin
  Result := (FThemeCategoryList.Objects[CategoryIndex] as TStringList).Strings[SchemeIndex];
end;
//****************************************************************************************************************************************************
function TiVCLComponent.GetThemeCategorySchemeIsUser(CategoryIndex, SchemeIndex: Integer): Boolean;
begin
  Result := (FThemeCategoryList.Objects[CategoryIndex] as TStringList).Objects[SchemeIndex] is TiUserSchemeList;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.SeparateNameValue(AText: String; var Name: String; var Value: String);
var
  EqualPosition: Integer;
begin
  EqualPosition := AnsiPos('=', AText);
  if (EqualPosition <> 0) then
    begin
      Name  := Trim(Copy(AText, 1, EqualPosition - 1));
      Value := Copy(AText, EqualPosition + 2, Length(AText) - EqualPosition);
    end
  else
    begin
      Name  := '';
      Value := '';
    end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.ApplyScheme(CategoryIndex, SchemeIndex: Integer);
var
  x                   : Integer;
  AString             : String;
  AScheme             : TStringList;
  PropertyNameString  : String;
  PropertyValueString : String;
begin
  AScheme := (FThemeCategoryList.Objects[CategoryIndex] as TStringList).Objects[SchemeIndex] as TStringList;
  for x := 0 to AScheme.Count - 1 do
    begin
      AString := AScheme.Strings[x];
      SeparateNameValue(AString, PropertyNameString, PropertyValueString);
      if (PropertyNameString <> '') then OPCSetProperty(Self, '', PropertyNameString, PropertyValueString);
    end;
end;
//****************************************************************************************************************************************************
end.