videownd.pas

these are some texts and original program,they are very useful for transportation reserch.

unit VideoWnd;
{
  last:06-11-14
}

interface

uses
  SysUtils, Classes, Controls, ExtCtrls,Messages,Graphics,Windows,DrawDib;

type
  TVideoWnd = class(TCustomControl)
  private
    { Private declarations }
    m_Image:array of Byte;

    m_HDC:HDC;
    m_HDD:HWND; //drawdib handle

    m_CS:TRTLCriticalSection;
    FImgVisible:Boolean; //显示图像
    FChrVisible:Boolean; //显示字符线条等

    procedure OnEreaseBk(var Msg:TMessage);message WM_ERASEBKGND;  //防止闪烁
    procedure PaintBmp();


    procedure FSetImageVisible(val:Boolean);
  protected
    { Protected declarations }
    procedure BeginPaint();
    procedure EndPaint();

    procedure Paint;override;
  public
    { Public declarations }
    constructor Create(AOwner:TComponent);override;
    destructor Destroy();override;

    procedure DrawImage(image:Pointer;bInverse:Boolean=true);
    procedure Move(x0,y0,nWidth,nHeight:Integer);

    procedure TextOut(X, Y: Integer; const Text: string; color:TColor=clRed); //屏幕坐标
    //对应BMP坐标，显示时缩放
    procedure MoveTo(X, Y: Integer);
    procedure LineTo(X, Y: Integer; color:TColor=clRed);
    procedure Rectangle(X1, Y1, X2, Y2: Integer; color:TColor=clRed);
    procedure Ellipse(X1, Y1, X2, Y2: Integer; color:TColor=clRed);

    function GetCanvas():TCanvas;
    /////////////////////////

    property XCanvas:TCanvas read GetCanvas;

  published
    { Published declarations }
    property Visible;
    property ImgVisible:Boolean read FImgVisible write FSetImageVisible default true;
    property ChrVisible:Boolean read FChrVisible write FChrVisible default true;

    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnClick;
    property OnDblClick;
    property OnResize;

  end;

procedure Register;

implementation
const
  IMGWIDTH=768;
  IMGHEIGHT=288;

procedure Register;
begin
  RegisterComponents('Samples', [TVideoWnd]);
end;

constructor TVideoWnd.Create(AOwner:TComponent);
begin
  Inherited;
  m_HDC:=0;
  m_Hdd:=0;
  FImgVisible:=true;
  FChrVisible:=true;
  m_Image:=nil;
  SetLength(m_Image,IMGWIDTH*IMGHEIGHT*3);
  InitializeCriticalSection(m_CS);
end;

destructor TVideoWnd.Destroy();
begin
  SetLength(m_Image,0);
  
  if (m_Hdd<>0) then
    DrawDibClose(m_Hdd);
  DeleteCriticalSection(m_CS);
  Inherited;
end;

procedure TVideoWnd.Paint;
begin
  Inherited;

  EnterCriticalSection(m_CS);
  BeginPaint();
  PaintBmp();
  EndPaint();
  LeaveCriticalSection(m_CS);
end;

procedure TVideoWnd.OnEreaseBk(var Msg:TMessage);
begin
  //do nothing
end;

procedure TVideoWnd.BeginPaint();
var
  bmpinfoh:TBitmapInfoHeader;
begin
  m_HDC:=self.Canvas.Handle;
  if (m_hdd=0) then
  begin
    bmpinfoh.biPlanes := 1;
    bmpinfoh.biSize := 40;
    bmpinfoh.biSizeImage := 0;
    bmpinfoh.biWidth := IMGWIDTH;
    bmpinfoh.biHeight := IMGHEIGHT;
    bmpinfoh.biBitCount := 24;
    bmpinfoh.biClrUsed := 0;
    bmpinfoh.biCompression := BI_RGB;

    m_hdd:=DrawDibOpen();
    DrawDibBegin(m_hdd,m_hDC,GetSystemMetrics(SM_CXSCREEN),GetSystemMetrics(SM_CYSCREEN),@bmpinfoh,
                bmpinfoh.biWidth,bmpinfoh.biHeight,DDF_SAME_HDC);
    DrawDibRealize(m_hdd,m_hDC,false);
  end;

end;

procedure TVideoWnd.EndPaint();
begin
end;

procedure TVideoWnd.PaintBmp();
var
  bmpinfoh:TBitmapInfoHeader;
  bmpinfo:TBitmapinfo;
  rect:TRect;
begin
  if FImgVisible then
  begin
  	bmpinfoh.biPlanes := 1;
  	bmpinfoh.biSize := 40;
  	bmpinfoh.biSizeImage := 0;
  	bmpinfoh.biWidth := IMGWIDTH;
  	bmpinfoh.biHeight := IMGHEIGHT;
  	bmpinfoh.biBitCount := 24;
  	bmpinfoh.biClrUsed := 0;
  	bmpinfoh.biCompression := BI_RGB;

    bmpinfo.bmiHeader:=bmpinfoh;
    if m_Image<>nil then
    begin
      SetStretchBltMode(m_HDC,HALFTONE);
//      StretchDIBits(m_HDC,0,0,self.Width,self.Height,0,0,IMGWIDTH,IMGHEIGHT,
//        m_Image,bmpinfo,DIB_RGB_COLORS,SRCCOPY);
      DrawDibDraw(m_Hdd,m_hDC,0,0,self.Width,self.Height,
        @bmpinfoh,m_Image,0,0,bmpinfoh.biWidth,bmpinfoh.biHeight,DDF_SAME_DRAW or DDF_SAME_HDC);
    end;
  end
  else
  begin
    Self.Canvas.Brush.Color:=clGreen;
    rect.Left:=0; rect.Top:=0; rect.Right:=Self.Width; rect.Bottom:=Self.Height;
    Self.Canvas.FillRect(rect);
  end;
end;

///////////////////////////////////////////////////////////////////////////////
procedure TVideoWnd.FSetImageVisible(val:Boolean);
begin
  FImgVisible:=val;
  Self.Repaint;
end;

function TVideoWnd.GetCanvas():TCanvas;
begin
  Result:=Self.Canvas;
end;
////////////////////////////////////////////////////////////////////////////////
procedure TVideoWnd.DrawImage(image:Pointer;bInverse:Boolean=true);
var
  y:Integer;
begin
  EnterCriticalSection(m_CS);
  if not bInverse then
    CopyMemory(@m_Image[0],image,IMGWIDTH*IMGHEIGHT*3)
  else
  begin
    for y:=0 to IMGHEIGHT-1 do
    begin
      CopyMemory(@m_Image[(IMGHEIGHT-1-y)*IMGWIDTH*3],PChar(image)+y*IMGWIDTH*3,IMGWIDTH*3);
    end;
  end;
  LeaveCriticalSection(m_CS);

  Self.Repaint;
end;

procedure TVideoWnd.Move(x0,y0,nWidth,nHeight:Integer);
begin
  MoveWindow(self.Handle,x0,y0,nWidth,nHeight,true);
end;

procedure TVideoWnd.TextOut(X, Y: Integer; const Text: string; color:TColor);
var
  dc:HDC;
begin
  if FChrVisible then
  begin
    Self.Canvas.Lock;
    dc:=Self.Canvas.Handle;
    SetBkMode(dc,Windows.TRANSPARENT);
    Self.Canvas.Font.Color:=color;
    Self.Canvas.TextOut(x,y,Text);
    Self.Canvas.Unlock;
  end;
end;

procedure TVideoWnd.MoveTo(X, Y: Integer);
begin
  if FChrVisible then
  begin
    Self.Canvas.Lock;
    Self.Canvas.MoveTo(X * Self.Width div IMGWIDTH,Y * Self.Height div IMGHEIGHT);
    Self.Canvas.Unlock;
  end;
end;

procedure TVideoWnd.LineTo(X, Y: Integer; color:TColor);
begin
  if FChrVisible then
  begin
    Self.Canvas.Lock;
    Self.Canvas.Pen.Color:=color;
    Self.Canvas.LineTo(X * Self.Width div IMGWIDTH,Y * Self.Height div IMGHEIGHT);
    Self.Canvas.Unlock;
  end;
end;

procedure TVideoWnd.Rectangle(X1, Y1, X2, Y2: Integer; color:TColor);
begin
  if FChrVisible then
  begin
    MoveTo(X1,Y1);
    LineTo(X2,Y1,color);
    LineTo(X2,Y2,color);
    LineTo(X1,Y2,color);
    LineTo(X1,Y1,color);
  end;
end;

procedure TVideoWnd.Ellipse(X1, Y1, X2, Y2: Integer; color:TColor);
var
  brush:HBrush;
var
  dc:HDC;
begin
  if FChrVisible then
  begin
    Self.Canvas.Lock;
    dc:=Self.Canvas.Handle;
    brush:=SelectObject(dc,GetStockObject(NULL_BRUSH));
    Self.Canvas.Pen.Color:=color;
    Self.Canvas.Ellipse(x1 *Width div IMGWIDTH,y1 *Height div IMGHEIGHT,
                        x2 *Width div IMGWIDTH,y2 *Height div IMGHEIGHT);
    SelectObject(dc,brush);
    Self.Canvas.Unlock;
  end;
end;

end.