untmain.pas

简要说明:对医院幼儿心理情况做的一个调查,统计系统.

unit untMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ActnList,untGlobalVar, ComCtrls, ToolWin, Buttons,StdCtrls,
  AAFont, AACtrls, jpeg, ExtCtrls,Math, ImgList;

type
  TfrmMain = class(TForm)
    mnuMain: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    N5: TMenuItem;
    N6: TMenuItem;
    N7: TMenuItem;
    N8: TMenuItem;
    N9: TMenuItem;
    N10: TMenuItem;
    N12: TMenuItem;
    N13: TMenuItem;
    N14: TMenuItem;
    N15: TMenuItem;
    N16: TMenuItem;
    actMain: TActionList;
    actDataInput: TAction;
    actReport: TAction;
    actQuestionGrp: TAction;
    actQuestion: TAction;
    actMeasure: TAction;
    actSchool: TAction;
    actStudent: TAction;
    actJudge: TAction;
    actReportText: TAction;
    actQuit: TAction;
    actImportData: TAction;
    N17: TMenuItem;
    actWord: TAction;
    actreportprint: TAction;
    N19: TMenuItem;
    actDeleteData: TAction;
    PnlMainL: TPanel;
    PnlMenu1: TPanel;
    ImgMenu1: TImage;
    albl1: TAALabel;
    PnlMenu2: TPanel;
    ImgMenu2: TImage;
    albl2: TAALabel;
    PnlMenu3: TPanel;
    ImgMenu3: TImage;
    albl3: TAALabel;
    PnlList: TPanel;
    ImgPnl: TImage;
    btnTop: TSpeedButton;
    btnBottom: TSpeedButton;
    pnlSide: TPanel;
    PnlMenu4: TPanel;
    ImgMenu4: TImage;
    albl5: TAALabel;
    CoolBar1: TCoolBar;
    ToolBar1: TToolBar;
    StatusBar1: TStatusBar;
    ImgMain: TImage;
    ImgDrawLeft: TImage;
    S24ToolBar: TImageList;
    actwork: TAction;
    actEdu: TAction;
    actEditPWD: TAction;
    N11: TMenuItem;
    actEdu1: TMenuItem;
    N22: TMenuItem;
    actEditPWD1: TMenuItem;
    actuser: TAction;
    N23: TMenuItem;
    Actemportdatra: TAction;
    ImgDraw: TImage;
    N18: TMenuItem;
    procedure actQuitExecute(Sender: TObject);
    procedure actQuestionGrpExecute(Sender: TObject);
    procedure actQuestionExecute(Sender: TObject);
    procedure actMeasureExecute(Sender: TObject);
    procedure actSchoolExecute(Sender: TObject);
    procedure actStudentExecute(Sender: TObject);
    procedure actJudgeExecute(Sender: TObject);
    procedure actImportDataExecute(Sender: TObject);
    procedure actReportTextExecute(Sender: TObject);
    procedure actReportExecute(Sender: TObject);
    procedure actWordExecute(Sender: TObject);
    procedure actreportprintExecute(Sender: TObject);
    procedure actDeleteDataExecute(Sender: TObject);
    procedure actPatientMeasureExecute(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure actworkExecute(Sender: TObject);
    procedure actEduExecute(Sender: TObject);
    procedure actEditPWDExecute(Sender: TObject);
    procedure actuserExecute(Sender: TObject);
    procedure ActemportdatraExecute(Sender: TObject);
  private
    { Private declarations }
    FLoginInfo:TUserRec;
    MenuItemCnt : Integer;                         //确定可显示几个子菜单
    procedure ImgMenuClick(Sender: TObject);       //抽屈
    procedure AddListMenu(MenuN: Integer);
    procedure FraLabMouseEnter(Sender: TObject);
    procedure FraLabMouseLeave(Sender: TObject);
    procedure SetLoginInfo(const Value: TUserRec);
    procedure DrawImg;
  public
    { Public declarations }
    
    procedure RefreshLog;
    property LoginInfo:TUserRec read FLoginInfo write SetLoginInfo;
    procedure AdvancedDrawMenuItem(Sender: TObject; ACanvas: TCanvas;
      ARect: TRect; State: TOwnerDrawState);
  end;



var
  frmMain: TfrmMain;

function GetImageTag(MenuN: string; ItemN: Integer): string;

implementation

uses untDM, untQuestionGrp, untQuestions, untMeasure, untSchool, //untStudent,
  untJudgeStd, untImportData, untReportText, untStudentCondition,
  untSelectStudent, untSuggestWord, untExportCondition, untExportData,
  untDeleteData,untMeasureCase, untStudent,UFraMenu,untWorkSet,UntEduSet,
  untBaseSingle,untEditPWD,untUser, untExportExecl;

function GetImageTag(MenuN: string; ItemN: Integer): string;
begin
  Result := '0';
  if MenuN = '0' then
  begin
    if ItemN = 0 then Result := '0';
    if ItemN = 1 then Result := '1';
    if ItemN = 2 then Result := '2';
    if ItemN = 3 then Result := '3';
    if ItemN = 4 then Result := '4';
    if ItemN = 5 then Result := '5';
    if ItemN = 6 then Result := '6';
  end
  else if MenuN = '1' then
  begin
    if ItemN = 0 then Result := '5';
    if ItemN = 1 then Result := '6';
    if ItemN = 2 then Result := '7';
    if ItemN = 3 then Result := '8';
  end
  else if MenuN = '2' then
  begin
    if ItemN = 0 then Result := '0';
    if ItemN = 1 then Result := '1';
    if ItemN = 2 then Result := '2';
    if ItemN = 3 then Result := '3';
    if ItemN = 4 then Result := '4';
    if ItemN = 5 then Result := '5';
    if ItemN = 6 then Result := '6';
  end
  else if MenuN = '3' then
  begin
    if ItemN = 0 then Result := '14';
    if ItemN = 1 then Result := '15';
    if ItemN = 2 then Result := '16';
    if ItemN = 3 then Result := '17';
    if ItemN = 4 then Result := '18';
  end
  else if MenuN = '4' then
  begin
    if ItemN = 0 then Result := '19';
    if ItemN = 1 then Result := '20';
    if ItemN = 2 then Result := '21';
  end;
end;
{$R *.dfm}



procedure TfrmMain.ImgMenuClick(Sender: TObject);
var
  i : Integer;
begin
  if PnlMainL.Hint = TControl(Sender).Name then
    Exit;
  for i := 0 to PnlMainL.ControlCount - 1 do
  begin
    if UpperCase(Copy(PnlMainL.Controls[i].Name,1,7)) = 'PNLMENU' then
    begin
     if TPanel(TImage(Sender).Parent).Hint = 'T' then
      begin
        if (TPanel(PnlMainL.Controls[i]).Tag >= TPanel(TImage(Sender).Parent).Tag) then
        begin
          TPanel(PnlMainL.Controls[i]).Hint := 'B';
        end;
      end;
      if TPanel(TImage(Sender).Parent).Hint = 'B' then
      begin
        if (TPanel(PnlMainL.Controls[i]).Tag <= TPanel(TImage(Sender).Parent).Tag) then
        begin
          TPanel(PnlMainL.Controls[i]).Hint := 'T';
        end;
      end;
    end;
  end;

  if TPanel(TImage(Sender).Parent).Hint = 'T' then
  begin
    for i := 1 to TPanel(TImage(Sender).Parent).Tag do
    begin
      TPanel(PnlMainL.FindChildControl('PnlMenu'+IntToStr(i))).Align := alTop;
    end;
    for i := mnuMain.Items.Count downto TPanel(TImage(Sender).Parent).Tag + 1 do
    begin
      TPanel(PnlMainL.FindChildControl('PnlMenu'+IntToStr(i))).Align := alBottom;
    end;
  end;

  AddListMenu(TPanel(TImage(Sender).Parent).Tag-1);
  PnlMainL.Hint := TControl(Sender).Name;
end;

//加入列表项目到Bar中
procedure TfrmMain.AddListMenu(MenuN: Integer);
  function IsScrollBut(Bh: Integer): Boolean;
  var
    k,iSum: Integer;
  begin
    iSum := 0;
    for k:=0 to mnuMain.Items[Bh].Count-1 do
      if mnuMain.Items[Bh].Items[k].Caption <> '-' then
        Inc(iSum);
    Result := iSum > MenuItemCnt;
  end;
var
  i, j: Integer;
  FRA : TFraMenu;
  MenuNm : String;
  strHint: string;
begin
  btnTop.Visible := False;
  btnBottom.Visible := False;
  for i := PnlList.ControlCount-1 downto 0 do
  begin
    if UpperCase(Copy(PnlList.Controls[i].Name,1,3)) = 'FRA' then
      TFraMenu(PnlList.Controls[i]).Free;
  end;

  if MenuN > mnuMain.Items.Count - 1 then
     Exit;
  j:=0;
  for i := 0 to mnuMain.Items[MenuN].Count - 1 do
  begin
    strHint := mnuMain.Items[MenuN].Items[i].Hint;
    if (mnuMain.Items[MenuN].Items[i].Caption <> '-') then
    begin
      if j > MenuItemCnt - 1 then
        Break;
      FRA := TFraMenu.Create(nil);
      FRA.Parent := PnlList;
      FRA.Left := Floor((PnlList.Width-FRA.Width)/2);
      FRA.Top := j * FRA.Height + 10;
      MenuNm := mnuMain.Items[MenuN].Items[i].Caption;
      if Pos('(',MenuNm) > 0 then
        MenuNm := Copy(MenuNm,1,Pos('(',MenuNm)-1);
      if Length(MenuNm) > 10 then
        FRA.alMenu.Caption := Copy(MenuNm,1,8)+'..'
      else
        FRA.alMenu.Caption := MenuNm;
      //FRA.ImgMenuItem.Picture.Assign(ImageList1.);
      DM.ilBox.GetBitmap(StrToInt(GetImageTag(IntToStr(MenuN),i)),FRA.ImgMenuItem.Picture.Bitmap);
      FRA.LabMenu.OnMouseEnter := FraLabMouseEnter;
      FRA.LabMenu.OnMouseLeave := FraLabMouseLeave;
      FRA.LabMenu.Hint := MenuNm;
      FRA.LabMenu.OnClick := mnuMain.Items[MenuN].Items[i].OnClick;
      FRA.Name:='FRA'+IntToStr(j);
      Inc(j);
    end;
  end;
  //记录主菜单项
  btnTop.Tag := MenuN;
  //记录子菜单位置
  btnBottom.Tag := i-1;
  //确定是否需要加入滚动按钮
  btnTop.Visible := IsScrollBut(MenuN);
end;

procedure TfrmMain.DrawImg;
var
  iHei, iWid, iBmpHei, iBmpWid: integer;
  iCurX, iCurY, iCopyRight, iCopyBottom, iCopyWid, iCopyHei: integer;
  RectDest, RectSour: TRect;
  pBitmap: TBitmap;
begin
  iBmpHei := ImgMain.Height;
  iBmpWid := ImgMain.Width;
  iHei := Screen.Height;
  iWid := PnlList.Width;
  pBitmap := TBitmap.Create;
  pBitmap.Width := iWid;
  pBitmap.Height := iHei;
  iCurY := 0;
  while iCurY < iHei do
  begin
    iCurX := 0;
    while iCurX < iWid do
    begin
      if iCurY + iBmpHei > iHei then
      begin
        iCopyBottom := iHei;
        iCopyHei := iHei - iCurY;
      end
      else
      begin
        iCopyBottom := iCurY + iBmpHei;
        iCopyHei := iBmpHei;
      end;
      if iCurX + iBmpWid > iWid then
      begin
        iCopyRight := iWid;
        iCopyWid := iWid - iCurX;
      end
      else
      begin
        iCopyRight := iCurX + iBmpWid;
        iCopyWid := iBmpWid;
      end;
      RectDest := Rect(iCurX, iCurY, iCopyRight, iCopyBottom);
      RectSour := Rect(0, 0, iCopyWid, iCopyHei);
      pBitmap.Canvas.CopyRect(RectDest, ImgMain.Canvas, RectSour);

      iCurX := iCurX + iBmpWid;
    end;
    iCurY := iCurY + iBmpHei;
  end;
  ImgPnl.Picture.Assign(pBitmap);
  pBitmap.Free;   //}
end;


procedure TfrmMain.FraLabMouseEnter(Sender: TObject);
begin
  TFraMenu(TLabel(Sender).Parent).alMenu.Font.Color := clRed;
  TFraMenu(TLabel(Sender).Parent).alMenu.Effect.FontEffect.Shadow.Enabled := False;
end;

procedure TfrmMain.FraLabMouseLeave(Sender: TObject);
begin
  TFraMenu(TLabel(Sender).Parent).alMenu.Font.Color := clBlue;
  TFraMenu(TLabel(Sender).Parent).alMenu.Effect.FontEffect.Shadow.Enabled := True;
end;

procedure TfrmMain.AdvancedDrawMenuItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; State: TOwnerDrawState);
var
  sCaption: string;
begin
 With ACanvas do
  Begin
    bitblt(handle,Arect.Left,Arect.Top,(Arect.Right-Arect.Left),(Arect.Bottom-Arect.Top),
      ImgDraw.Canvas.Handle,Arect.Left,Arect.Top,srccopy);
    bitblt(handle,Arect.Left,Arect.Top,mnuMain.Images.Width+4,(Arect.Bottom-Arect.Top),
      ImgDrawLeft.Canvas.Handle,Arect.Left,Arect.Top,srccopy);
    if odselected in State then
    Begin
        Brush.Color:=$00FAE8DE;
        Font.color:=ClRed;//ClWhite;
        Brush.Style:=BsClear;//BsSolid;
        Pen.Color:=Clgray;
        Pen.Width:=1;
        RoundRect(ARect.Left+mnuMain.Images.Width+5,ARect.Top,Arect.Right,Arect.Bottom,7,7);
        Pen.Color:=ClSilver;
        Pen.Width:=1;
        RoundRect(ARect.Left+mnuMain.Images.Width+6,ARect.Top+1,Arect.Right-1,Arect.Bottom-1,5,5);
        if (TMenuItem(Sender).ImageIndex<>-1)
          and (TMenuItem(Sender).ImageIndex<mnuMain.Images.Count) then
        Begin
          Pen.Color:=ClWhite;
          Pen.Width:=1;
          RoundRect(Arect.Left+1,Arect.Top, Arect.Left+mnuMain.Images.Width+3,Arect.Bottom-1,4,4);
          Pen.Color:=Clgray;
          Pen.Width:=1;
          RoundRect(Arect.Left+2,Arect.Top+1, Arect.Left+mnuMain.Images.Width+2,Arect.Bottom-2,3,3);
        End;
    End
    Else
    Begin
      Brush.Color := $00d2d2d2;
      Brush.Style := BsClear;
    End;
    if Not TMenuItem(Sender).Enabled Then
      Font.color := Clgray;
    FillRect(ARect);
    if Not TMenuItem(Sender).IsLine Then begin
      sCaption := TMenuItem(Sender).Caption;
      if Pos('(', sCaption)>0 then
        sCaption := Copy(sCaption, 1, Pos('(', sCaption)-1);
      TextRect(ARect,ARect.Left+12+mnuMain.Images.Width,
        ARect.Top+((Arect.Bottom-Arect.Top) div 2)-5,sCaption);