u_prew_main.pas

企业安防管理系统

unit U_prew_main;
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ExtCtrls, Menus, ImgList, DSPack, DSUtil, DirectShow9, ToolWin, ActnList,
  jpeg, StdCtrls, Buttons,dateutils,strutils,u_public;

type
  Tfrm_prew_Main = class(TForm)
    ImageList: TImageList;
    Timer1: TTimer;
    SaveDialog1: TSaveDialog;
    PopupMenu1: TPopupMenu;
    Play1: TMenuItem;
    Stop1: TMenuItem;
    N1: TMenuItem;
    Capture1: TMenuItem;
    Bitmap1: TMenuItem;
    N2: TMenuItem;
    FullScreen1: TMenuItem;
    OnTop1: TMenuItem;
    N3: TMenuItem;
    Close1: TMenuItem;
    ActionList1: TActionList;
    A_Option: TAction;
    A_Play: TAction;
    A_Stop: TAction;
    StatusBar1: TStatusBar;
    A_Capture: TAction;
    A_OnTop: TAction;
    A_FullScreen: TAction;
    A_Bitmap: TAction;
    A_Exit: TAction;
    SampleGrabber1: TSampleGrabber;
    SaveDialog2: TSaveDialog;
    OpenDialog1: TOpenDialog;
    A_File: TAction;
    N7: TMenuItem;
    E2: TMenuItem;
    ASFWriter1: TASFWriter;
    GroupBox1: TGroupBox;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Panel4: TPanel;
    Panel5: TPanel;
    Panel6: TPanel;
    Panel7: TPanel;
    Panel8: TPanel;
    Panel9: TPanel;
    Im1: TImage;
    Im2: TImage;
    Im3: TImage;
    Im4: TImage;
    Im5: TImage;
    Im6: TImage;
    Im7: TImage;
    Im8: TImage;
    Im9: TImage;
    Timer2: TTimer;
    Image2: TImage;
    VideoWindow1: TVideoWindow;
    Image1: TImage;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton6: TSpeedButton;
    SpeedButton7: TSpeedButton;
    SpeedButton3: TSpeedButton;
    procedure A_OptionExecute(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure A_PlayExecute(Sender: TObject);
    procedure A_StopExecute(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure A_CaptureExecute(Sender: TObject);
    procedure A_OnTopExecute(Sender: TObject);
    procedure A_FullScreenExecute(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
      procedure Lx_ok1;
    procedure A_ExitExecute(Sender: TObject);
    procedure A_BitmapExecute(Sender: TObject);
    procedure A_FileExecute(Sender: TObject);
    procedure SampleGrabber1Buffer(sender: TObject; SampleTime: Double;
      pBuffer: Pointer; BufferLen: Integer);
    procedure SpeedButton4Click(Sender: TObject);
    procedure  Bool_Lx;//是否有录像检测
    procedure Timer2Timer(Sender: TObject); //是否录像打开
    procedure  DatePD;//日期判断，星期判断

    procedure  KSLX;
    procedure FormCreate(Sender: TObject);
  private
    CapFName: WideString;
    M_Bool_LX:Boolean;//是否录像
    M_Bool_DQLX:Boolean;//当前是否正在录像
    M_Bool_KSLX:Boolean;//开始录像
    DayBoolLx:array[1..8] of boolean;//所在星期是否有录像
    LX_Now:Boolean;//当天是否有录像
    NowWeek:integer;//当前星期
    LX_Sj:Array[1..8,1..2] of string;
    Lx_OK:array[1..8] of boolean;
    //0为星期天，1为星期一.....6为星期六
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frm_prew_Main: Tfrm_prew_Main;

implementation

uses U_Option,u_set_bfyy, U_Prew_HF, Datamodal;

{$R *.dfm}

procedure Tfrm_prew_Main.A_OptionExecute(Sender: TObject);
begin
  frm_Option.ShowModal;
end;

procedure Tfrm_prew_Main.Timer1Timer(Sender: TObject);
var
  Position: int64;
  Rate: Double;
  Hour, Min, Sec, MSec: Word;
const
  MiliSecInOneDay = 86400000;
begin
  if frm_Option.FilterGraph.Active then
  begin
    with frm_Option.FilterGraph as IMediaSeeking do
    begin
      GetCurrentPosition(Position);
      GetRate(Rate);
    end;
    DecodeTime(Position div 10000 / MiliSecInOneDay, Hour, Min, Sec, MSec);
    StatusBar1.SimpleText := Format('%d:%d:%d:%d', [Hour, Min, Sec, MSec]);
  end;
end;


procedure Tfrm_prew_Main.A_PlayExecute(Sender: TObject);
var
  Multiplexer: IBaseFilter;
  Writer: IFileSinkFilter;
  PinList: TPinList;
  i: integer;
  FSize: TPoint;
begin
  Bool_Lx;//录像功能是否被启动
  with frm_Option do
  begin
    if CB_VideoFormats.ItemIndex <> -1 then
    begin
      FSize := GetMediaTypeOfSize(VideoMediaTypes.Items[CB_VideoFormats.ItemIndex].AMMediaType^);

    end;

    FilterGraph.Mode := gmCapture;

    FilterGraph.Active := true;

    if AudioSourceFilter.FilterGraph <> nil then
    begin
      PinList := TPinList.Create(AudioSourceFilter as IBaseFilter);
      i := 0;
      while i < PinList.Count do
        if PinList.PinInfo[i].dir = PINDIR_OUTPUT then
        begin
          if CB_AudioFormats.ItemIndex <> -1 then
            with (PinList.Items[i] as IAMStreamConfig) do
              SetFormat(AudioMediaTypes.Items[CB_AudioFormats.ItemIndex].AMMediaType^);
          PinList.Delete(i);
        end else inc(i);
      if CB_InputLines.ItemIndex <> -1 then
        with (PinList.Items[CB_InputLines.ItemIndex] as IAMAudioInputMixer) do
          put_Enable(true);
      PinList.Free;
    end;

    if VideoSourceFilter.FilterGraph <> nil then
    begin
      PinList := TPinList.Create(VideoSourceFilter as IBaseFilter);
      if CB_VideoFormats.ItemIndex <> -1 then
        with (PinList.First as IAMStreamConfig) do
          SetFormat(VideoMediaTypes.Items[CB_VideoFormats.ItemIndex].AMMediaType^);
      PinList.Free;
    end;

    with FilterGraph as IcaptureGraphBuilder2 do
    begin

      if VideoSourceFilter.BaseFilter.DataLength > 0 then
        RenderStream(@PIN_CATEGORY_PREVIEW, nil, VideoSourceFilter as IBaseFilter,
          nil, VideoWindow1 as IBaseFilter);

      if M_Bool_kslx then//开始录像
      begin
         
         M_Bool_DQLX:=true;
        SetOutputFileName(MEDIASUBTYPE_Avi, PWideChar(CapFName), Multiplexer, Writer);
         speedbutton5.Caption:='停止录像';
        if VideoSourceFilter.FilterGraph <> nil then
          RenderStream(@PIN_CATEGORY_CAPTURE, nil, VideoSourceFilter as IBaseFilter,
            nil, Multiplexer as IBaseFilter);

        if AudioSourceFilter.FilterGraph <> nil then
        begin
          RenderStream(nil, nil, AudioSourceFilter as IBaseFilter,
            nil, Multiplexer as IBaseFilter);
        end;
      end;
    end;
    FilterGraph.Play;
    Timer1.Enabled := true;
  end;
  A_Play.Checked := True;
  A_Capture.Enabled := True;
end;

procedure Tfrm_prew_Main.A_StopExecute(Sender: TObject);
begin
  Timer1.Enabled := False;
  A_Play.Checked := False;
  frm_Option.FilterGraph.Stop;
  frm_Option.FilterGraph.Active := False;
  
  VideoWindow1.Canvas.Lock;
  try
    VideoWindow1.Canvas.StretchDraw(VideoWindow1.Canvas.ClipRect, Image1.Picture.Graphic);
  finally
    VideoWindow1.Canvas.Unlock;
  end;
end;

procedure Tfrm_prew_Main.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  A_Stop.Execute;
end;

procedure Tfrm_prew_Main.A_CaptureExecute(Sender: TObject);
begin
  if speedbutton5.Caption='停止录像' then
     begin
        A_Stop.Execute;
        A_Capture.Checked := False;
        m_bool_kslx:=false;
        CapFName := '';
        A_Play.Execute;
         speedbutton5.Caption:='录像';
        exit;
     end;

  if CapFName = '' then
  begin
    if not SaveDialog1.Execute then Exit;
     A_Stop.Execute;
    A_Capture.Checked := True;
    m_bool_kslx:=true;
    CapFName := SaveDialog1.FileName;
    speedbutton5.Caption:='停止录像';
  end else
  begin
    speedbutton5.Caption:='录像';
    A_Capture.Checked := False;
     m_bool_kslx:=false;
    CapFName := '';
  end;
  A_Play.Execute;
end;

procedure Tfrm_prew_Main.A_OnTopExecute(Sender: TObject);
begin
  A_OnTop.Checked := not A_OnTop.Checked;
  if A_OnTop.Checked then
    SetWindowPos(handle, HWND_TOPMOST, Left, Top, Width, Height, 0) else
    SetWindowPos(handle, HWND_NOTOPMOST, Left, Top, Width, Height, 0);
end;

procedure Tfrm_prew_Main.A_FullScreenExecute(Sender: TObject);
begin
  A_FullScreen.Checked := not A_FullScreen.Checked;
  VideoWindow1.FullScreen := A_FullScreen.Checked;
end;

procedure Tfrm_prew_Main.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin

  if Key = 27 then
  begin
    A_FullScreen.Checked := True;
    A_FullScreen.Execute;
  end;
end;

procedure Tfrm_prew_Main.A_ExitExecute(Sender: TObject);
begin
  Close;
end;

procedure Tfrm_prew_Main.A_BitmapExecute(Sender: TObject);
var
  ABitmap: TBitmap;

begin
  if not SaveDialog2.Execute then exit;
  ABitmap := TBitmap.Create;

  try

    SampleGrabber1.GetBitmap(ABitmap);

    ABitmap.SaveToFile(SaveDialog2.FileName);
  finally

    ABitmap.Free;
  end;
end;