ivclcomponent.pas

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

    end
  else
    Message.Result := DefWindowProc(FWindowHandle, Message.Msg, Message.wParam, Message.lParam);
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.GetTransparentBitmap;
var
  AllVisible : Boolean;
begin
  if FNeedsTransparentCapture then
    begin
      AllVisible := True;
      if not PtVisible(Canvas.Handle, 5,              5) then AllVisible := False;
      if not PtVisible(Canvas.Handle, Width-5,        5) then AllVisible := False;
      if not PtVisible(Canvas.Handle, 5,       Height-5) then AllVisible := False;
      if not PtVisible(Canvas.Handle, Width-5, Height-5) then AllVisible := False;

      if not AllVisible then
      begin
        with FTransparentBitmap.Canvas do
          begin
            Brush.Style := bsSolid;
            Brush.Color := BackGroundColor;
            FillRect(Rect(0, 0 ,Width, Height));
          end;
        Exit;
      end;

      FTransparentBitmap.Canvas.CopyRect(Rect(0, 0, Width, Height), Canvas, Rect(0, 0, Width, Height));
      FNeedsTransparentCapture := False;
    end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.RequestTransparentCapture;
begin
  if FTransparent and not FNeedsTransparentCapture then
    begin
      FNeedsTransparentCapture := True;
      BackGroundChange;
      SetWindowLong(Handle, GWL_HWNDPARENT, GetParent(Handle));
    end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.SetTransparent(const Value: Boolean);
begin
  if FTransparent <> Value then
    begin
      FTransparent := Value;
      if FTransparent then
        begin
          SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_TRANSPARENT);
          if not Assigned(FTransparentBitmap) then
            begin
              FTransparentBitmap        := TBitmap.Create;
              FTransparentBitmap.Width  := Width;
              FTransparentBitmap.Height := Height;
              RequestTransparentCapture;
            end;
          RequestTransparentCapture;
        end
      else
        begin
          SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) and (not WS_EX_TRANSPARENT));
          if Assigned(FTransparentBitmap) then
            begin
              FTransparentBitmap.Free;
              FTransparentBitmap := nil;
            end;
        end;
      BackGroundChange;
    end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.DrawBackGround(Canvas: TCanvas; BackGroundColor: TColor);
begin
  if FPaintDCTransparent then Exit;
  if FTransparent then
    begin
      FTransparentBitmap.Handle;
      if FNeedsTransparentCapture then GetTransparentBitmap;
      Canvas.Draw(0, 0, FTransparentBitmap);
    end
  else
    inherited DrawBackGround(Canvas, BackGroundColor);
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.RepaintAll;
begin
  inherited;
  RequestTransparentCapture;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.WndProc(var Message: TMessage);
begin
//  Lock;
  try
    inherited WndProc(Message);
  finally
//    Unlock;
  end;
end;
//****************************************************************************************************************************************************
function TiVCLComponent.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
  Result := iMouseWheel(WheelDelta, Shift, MousePos);
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  {$IFDEF iActiveX}
  Params.Style := Params.Style and not WS_TABSTOP;
  Params.Style := Params.Style and not WS_GROUP;
  {$ENDIF}
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.iPaintToDC(X, Y: Integer; Transparent: Boolean; DC: HDC);
var
  OldCachedDrawing : Boolean;
  SaveIndex        : Integer;
  ARegion          : HRGN;        
begin
  SaveIndex := SaveDC(DC);
  try
    SetViewportOrgEx(DC, 0, 0, nil);
    SetWindowOrgEx  (DC, -X, -Y, nil);
    SetMapMode      (DC, MM_TEXT);

    ARegion := CreateRectRgn(X, Y, X + Width, Y + Height);
    try
      SelectClipRgn(DC, ARegion);

      FPaintDCTransparent := Transparent;
      try
      try
        Lock;
        try
          Canvas.Handle := DC;
          Canvas.Refresh;
          OldCachedDrawing := CachedDrawing;
          CachedDrawing := False;
          try
            iPaintTo(Canvas);
          finally
            CachedDrawing := OldCachedDrawing;
          end;
        finally
          Unlock;
        end;
      except
        on exception do;
      end;
      finally
        FPaintDCTransparent := False;
      end;
      SelectClipRgn(DC, 0);
    finally
      DeleteObject(ARegion);
    end;
  finally
    RestoreDC(DC, SaveIndex);
  end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.SaveImageToJPEG(FileName: String; Compression: Integer; Progressive: Boolean);
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;
  Bitmap.Canvas.Lock;
  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;
    try
      JPEGImage.Assign(Bitmap);
      JPEGImage.CompressionQuality  := Compression;
      JPEGImage.Performance         := jpBestQuality;
      JPEGImage.PixelFormat         := jf24Bit;
      JPEGImage.ProgressiveEncoding := Progressive;
      JPEGImage.JPEGNeeded;
      JPEGImage.Compress;
      JPEGImage.SaveToFile(FileName);
    finally
      JPEGImage.Free;
    end;
    Bitmap.Canvas.UnLock;
    TControlCanvas(Canvas).FreeHandle;
  finally
    Bitmap.Free;
  end;
end;
//****************************************************************************************************************************************************
procedure TiVCLComponent.SaveImageToPNG(FileName: String; Compression: Integer);
var
  PNGObject : TPNGObject;
  Bitmap    : TBitmap;
begin
  if (Compression < 0) or (Compression > 9) then raise Exception.Create('Compression must be in the range of 0-9');
  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}

    PNGObject := TPNGObject.Create;
    try
      PNGObject.Assign(Bitmap);
      PNGObject.CompressionLevel := Compression;
      PNGObject.SaveToFile(FileName);
    finally
      PNGObject.Free;
    end;
  finally
    Bitmap.Free;
  end;
end;
//****************************************************************************************************************************************************
function TiVCLComponent.GetBytesJPEG(Compression: Integer; Progressive: Boolean): OleVariant;
var
  JPEGImage     : TJPEGImage;
  Bitmap        : TBitmap;
  MemoryStream  : TMemoryStream;
  P             : Pointer;
  AVariant      : OleVariant;
begin
  Lock;
  try
    if (Compression < 1) or (Compression > 100) then raise Exception.Create('Compression must be in the range of 1-100');
    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}

      JPEGImage := TJPEGImage.Create;
      try
        JPEGImage.CompressionQuality  := Compression;
        JPEGImage.Performance         := jpBestSpeed;
        JPEGImage.PixelFormat         := jf24Bit;
        JPEGImage.ProgressiveEncoding := Progressive;
        JPEGImage.Assign(Bitmap);

        MemoryStream := TMemoryStream.Create;
        try
          JPEGImage.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
        JPEGImage.Free;
      end;
      Bitmap.Canvas.Unlock;
    finally
      Bitmap.Free;
    end;
  finally
    UnLock;
  end;
end;
//****************************************************************************************************************************************************