frm_main.pas

delphi语言开发的矢量图形处理对象

    frmSetPic.pnlFore.Color :=curForeColor;
    frmSetpic.edtWidth.Text :=intTostr(drwCanvasWidth);
    frmSetpic.edtHeight.Text :=intTostr(drwCanvasHeight);
    TfrmDrw(activeMDIChild).reLoadBackSet;//设置已有的设置
    if frmSetpic.ShowModal =mrOk then
    begin
      TfrmDrw(activeMDIChild).setBkColor(frmSetpic.pnlBk.Color);
      curForeColor :=frmSetpic.pnlFore.Color;
      pnlFore.Color :=curForeColor;
      if length(frmSetpic.edtWidth.Text )<>0 then
      drwCanvasWidth:=strToint(frmSetpic.edtWidth.Text);
      if length(frmSetpic.edtHeight.Text )<>0 then
      drwCanvasHeight:=strToint(frmSetpic.edtHeight.Text);
      TfrmDrw(activeMDIChild).drwPaint.Width :=round(drwCanvasWidth*TfrmDrw(activeMDIChild).curZoomScale);
      TfrmDrw(activeMDIChild).drwPaint.Height :=round(drwCanvasHeight*TfrmDrw(activeMDIChild).curZoomScale);
      if frmSetPic.CheckBox1.Checked then
      begin
        TfrmDrw(activeMDIChild).setBackBitmap(frmSetPic.sFilePic,frmSetPic.ComboBox1.ItemIndex);
      end
      else begin
        TfrmDrw(activeMDIChild).setBackBitmap('none',0);
      end;
      TfrmDrw(activeMDIChild).draw_RamBitmap;
    end;
  finally
    frmSetpic.Free;
  end;
end;

procedure TfrmMain.LeftAlignExecute(Sender: TObject);
begin
  TFrmDrw(activeMDIChild).setAlign(TAlign(TAction(sender).Tag));
end;

procedure TfrmMain.WindowArrangeExecute(Sender: TObject);
begin
  Tile;
end;

procedure TfrmMain.windowCengDieExecute(Sender: TObject);
begin
  Cascade;
end;

procedure TfrmMain.winShowExecute(Sender: TObject);
var
  winActionItem:TActionClientItem;
  newAction:TAction;
  i:integer;
begin
  winActionItem:=actionManager1.FindItemByCaption('窗口【&W】');
  for i:=3 to winActionItem.Items.Count -1 do
  begin
    newAction:=TAction(winActionitem.Items[i].Action);
    newAction.Checked :=false;
  end;
  for i:=0 to MDIChildCount-1 do
  begin
    if TAction(Sender).Caption =TfrmDrw(MDIChildren[i]).Caption then
    begin
      TfrmDrw(MDIChildren[i]).BringToFront;
      TAction(Sender).Checked :=true;
      exit;
    end;
  end;
end;

procedure TfrmMain.createActionClient(sCaption: string);
var
  winActionItem,newItem:TActionClientItem;
  newAction:TAction;
  i:integer;
begin
  winActionItem:=actionManager1.FindItemByCaption('窗口【&W】');
  winActionItem.Items[2].Visible :=true;
  for i:=3 to winActionItem.Items.Count -1 do
  begin
    newAction:=TAction(winActionitem.Items[i].Action);
    newAction.Checked :=false;
  end;
  newItem:=winActionItem.Items[2];
  newAction:=getNewAction(sCaption);
  actionManager1.AddAction(newAction,NewItem);
  newAction.Checked :=true;
end;

function TfrmMain.getNewAction(sCaption: string): TAction;
var
  newAction:TAction;
begin
  inc(openFileNum);
  newAction:=TAction.Create(actionManager1);
  newAction.Caption :=sCaption;
  newAction.Category :='window';
  newAction.Name :='actShowFile'+intToStr(openFileNum);
  newAction.OnExecute :=winShow.OnExecute;
  result:=newAction;
end;

procedure TfrmMain.aboutExecute(Sender: TObject);
begin
  AboutBox:=TAboutBox.Create(Application);
  try
    AboutBox.ShowModal
  finally
    AboutBox.Free;
  end;
end;

procedure TfrmMain.ColorGrid1Change(Sender: TObject);
begin
  pnlBK.Color :=ColorGrid1.BackgroundColor;
  pnlFore.Color :=colorGrid1.ForegroundColor;
  curForeColor:=colorGrid1.ForegroundColor;
  curFillColor:=ColorGrid1.BackgroundColor;
end;

procedure TfrmMain.DelAction(var msg: TMessage);
var
  winActionItem:TActionClientItem;
  newAction:TAction;
  i:integer;
begin
  winActionItem:=actionManager1.FindItemByCaption('窗口【&W】');
  for i:=3 to winActionItem.Items.Count -1 do
  begin
    newAction:=TAction(winActionitem.Items[i].Action);
    if newAction.Checked then
    break;
  end;
  actionManager1.DeleteActionItems([newAction]);
  newAction.Free;
  if winActionItem.Items.Count=3 then
  begin
    winActionItem.Items[2].Visible :=false;
    exit;
  end;
  newAction:=TAction(winActionitem.Items[winActionItem.Items.count-1].Action);
  newAction.Checked :=true;
  for i:=0 to MDIChildCount-1 do
  begin
    if Tfrmdrw(MDIChildren[i]).Caption =newAction.Caption then
    Tfrmdrw(MDIChildren[i]).BringToFront;
  end;
end;

procedure TfrmMain.fontcomClick(Sender: TObject);
begin
  if activeMDIChild<>nil then
  TFrmdrw(activeMDIChild).redrawText;
end;

procedure TfrmMain.fontspinChange(Sender: TObject);
begin
  if (fontspin.Tag =1) or (trim(fontSpin.Text)='') then exit;
  if activeMDIChild<>nil then
  TFrmdrw(activeMDIChild).redrawText;
end;

procedure TfrmMain.btnBoldClick(Sender: TObject);
begin
  if activeMDIChild<>nil then
  TFrmdrw(activeMDIChild).redrawText;
end;

procedure TfrmMain.btnItalicClick(Sender: TObject);
begin
  if activeMDIChild<>nil then
  TFrmdrw(activeMDIChild).redrawText;
end;

procedure TfrmMain.btnLineClick(Sender: TObject);
begin
  if activeMDIChild<>nil then
  TFrmdrw(activeMDIChild).redrawText;
end;

procedure TfrmMain.Timer1Timer(Sender: TObject);
begin
  statusBar1.Panels[1].Text :='  当前日期：'+dateTostr(Now);
  statusBar1.Panels[2].Text :='  当前时间：'+TimeToStr(now);
end;

procedure TfrmMain.StatusBar1DrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
  statusBar1.Canvas.Brush.Color :=clMoneyGreen;
  statusBar1.Canvas.Brush.Style :=bsSolid;
  case Panel.Index of
    0:begin
      statusBar1.Canvas.Font.Color :=clBlue;
      statusBar1.Canvas.Font.Style :=[fsBold];
    end;
    1:statusBar1.Canvas.Font.Color :=clPurple;
    2:statusBar1.Canvas.Font.Color :=clPurple;
  end;
  statusBar1.Canvas.TextRect(rect,rect.Left,rect.Top+2 ,panel.Text);

end;

procedure TfrmMain.ZoomOutExecute(Sender: TObject);
var
  tmpValue:single;
begin
  tmpValue:=TfrmDrw(ActiveMDIChild).curZoomScale;
  tmpValue:=tmpValue+0.2;
  if tmpValue>2.6 then exit;
  TfrmDrw(ActiveMDIChild).ZoomInOut(tmpValue);
end;

procedure TfrmMain.ZoomInExecute(Sender: TObject);
var
  tmpValue:single;
begin
  tmpValue:=TfrmDrw(ActiveMDIChild).curZoomScale;
  tmpValue:=tmpValue-0.2;
  if tmpValue<0.2 then exit;
  TfrmDrw(ActiveMDIChild).ZoomInOut(tmpValue);
end;

procedure TfrmMain.fileBmpExecute(Sender: TObject);
var
  tmpFile:string;
  newBmp:TBitmap;
begin
  dlgSave.Filter :='bmp|*.bmp';
  dlgSave.Title :='输入一个文件名';
  if dlgSave.Execute then
  begin
    tmpFile:=dlgSave.FileName;
    if pos('.bmp',lowercase(tmpFile))=0 then
    tmpFile:=tmpFile+'.bmp';
    newBmp:=TBitmap.Create;
    try
     tfrmdrw(activeMDIChild).GetBmp(newBmp);
     newBmp.SaveToFile(tmpFile);
    finally
     newBmp.Free;
    end;
  end;
end;

procedure TfrmMain.fileJpegExecute(Sender: TObject);
var
  tmpfile:string;
begin
  dlgSave.Filter :='Jpeg|*.jpg';
  dlgSave.Title :='输入一个文件名称';
  if dlgSave.Execute then
  begin
    tmpFile:=dlgSave.FileName;
    if pos('.jpg',lowercase(tmpFile))=0 then
    tmpFile:=tmpFile+'.jpg';
    tfrmdrw(activeMDIChild).SaveToJpeg(tmpfile);
  end;
end;

procedure TfrmMain.ClientWndProc(var Message: TMessage);
begin
  case Message.Msg of
    // Capture the WM_ERASEBKGND messages and perform the client area drawing
    WM_ERASEBKGND:
      begin
        CallWindowProc(FOldClientProc, ClientHandle, Message.Msg, Message.wParam,
          Message.lParam);
        FDrawDC := TWMEraseBkGnd(Message).DC;
       // DrawStretched;
       //   DrawCentered;
          DrawTiled;
        Message.Result := 1;
      end;
    { Capture the scrolling messages and ensure the client area
      is redrawn by calling InvalidateRect }
    WM_VSCROLL, WM_HSCROLL:
      begin
        Message.Result := CallWindowProc(FOldClientProc, ClientHandle, Message.Msg,
          Message.wParam, Message.lParam);
        InvalidateRect(ClientHandle, nil, True);
      end;
    else
    // By Default, call the original window procedure
      Message.Result := CallWindowProc(FOldClientProc, ClientHandle, Message.Msg,
        Message.wParam, Message.lParam);
  end; { case }
end;

procedure TfrmMain.CreateWnd;
begin
  inherited CreateWnd;
  // Turn the ClientWndProc method into a valid window procedure
  FNewClientProc := MakeObjectInstance(ClientWndProc);
  // Get a pointer to the original window procedure
  FOldClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
  // Set ClientWndProc as the new window procedure
  SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FNewClientProc));
end;

procedure TfrmMain.DrawCentered;
var
  CR: TRect;
begin
  GetWindowRect(ClientHandle, CR);
   with image1 do
     BitBlt(FDrawDC, ((CR.Right - CR.Left) - Picture.Width) div 2,
            ((CR.Bottom - CR.Top) - Picture.Height) div 2,
            Picture.Graphic.Width, Picture.Graphic.Height,
            Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;

procedure TfrmMain.DrawStretched;
var
  CR: TRect;
begin
  GetWindowRect(ClientHandle, CR);
  StretchBlt(FDrawDC, 0, 0, CR.Right, CR.Bottom,
             image1.Picture.Bitmap.Canvas.Handle, 0, 0,
             image1.Picture.Width, image1.Picture.Height, SRCCOPY);
end;

procedure TfrmMain.DrawTiled;
var
  Row, Col: Integer;
  CR, IR: TRect;
  NumRows, NumCols: Integer;
begin
  GetWindowRect(ClientHandle, CR);
  IR := image1.ClientRect;
  NumRows := CR.Bottom div IR.Bottom;
  NumCols := CR.Right div IR.Right;
  with image1 do
    for Row := 0 to NumRows+1 do
      for Col := 0 to NumCols+1  do
        BitBlt(FDrawDC, Col * Picture.Width, Row * Picture.Height,
               Picture.Width, Picture.Height, Picture.Bitmap.Canvas.Handle,
               0, 0, SRCCOPY);
end;

procedure TfrmMain.rightDockPanelDockOver(Sender: TObject;
  Source: TDragDockObject; X, Y: Integer; State: TDragState;
  var Accept: Boolean);
var
  aRect:TRect;
begin
  Accept:=Source.Control is TfrmLib;
  if Accept then
  begin
    aRect.TopLeft :=rightDockPanel.ClientToScreen(Point(-ClientWidth div 4,0));
    aRect.BottomRight :=rightDockPanel.ClientToScreen(Point(0,rightDockPanel.Height));
    Source.DockRect :=aRect;
  end;
end;

procedure TfrmMain.rightDockPanelGetSiteInfo(Sender: TObject;
  DockClient: TControl; var InfluenceRect: TRect; MousePos: TPoint;
  var CanDock: Boolean);
begin
  CanDock:=DockClient is TfrmLib;
end;

procedure TfrmMain.rightDockPanelUnDock(Sender: TObject; Client: TControl;
  NewTarget: TWinControl; var Allow: Boolean);
begin
  if (Sender as Tpanel).DockClientCount =1 then
  rightDockPanel.Width :=0;
end;

procedure TfrmMain.rightDockPanelDockDrop(Sender: TObject;
  Source: TDragDockObject; X, Y: Integer);
begin
  if (Sender as TPanel).DockClientCount =1 then
  begin
    rightDockPanel.Width :=clientWidth div 5;
  end;
  (sender as TPanel).DockManager.ResetBounds(true);
end;

procedure TfrmMain.openLibExecute(Sender: TObject);
begin
  dlgOpen.Filter :='图库文件(*.lib)|*.lib';
  if dlgOpen.Execute then
  begin
    if frmLib=nil then
    begin
      frmLib:=TFrmLib.Create(Application);
      frmLib.LoadLib(dlgOpen.FileName);
      frmLib.ManualDock(rightDockPanel);
      frmLib.Show;
    end
    else
      frmLib.LoadLib(dlgOpen.FileName);
  end;
end;

procedure TfrmMain.loadLib;
var
  fileList:TStringList;
  i:integer;
begin
  fileList:=TStringList.Create;
  try
    searchLibFiles(fileList);
    if fileList.Count >0 then
    begin
      frmLib:=TFrmLib.Create(Application);
      try
       for i:=0 to fileList.Count -1 do
       frmLib.LoadLib(fileList.Strings[i]);
      except
       frmLib.Free;
       fileList.Free;
       exit;
      end;
    end;
    frmLib.ManualDock(RightDockPanel);
    frmLib.Show;
  finally
    fileList.Free;
  end;
end;

//遍历搜索图库文件
procedure TfrmMain.searchLibFiles(paraList: TStrings);
var
  sr:TSearchrec;
  findResult:integer;
  sPath:String;
begin
  sPath:=ExtractFilePath(Application.ExeName)+'Libs';
  findResult:=FindFirst(sPath+'\*.lib',faHidden+faReadOnly,sr);
  if findResult=0 then
  repeat
     paraList.Add(sPath+'\'+sr.Name);
  Until FindNext(sr)<>0 ;
  FindClose(sr);
end;

procedure TfrmMain.Splitter2Paint(Sender: TObject);
begin
   if activeMDIChild<>nil then
   TFrmDrw(activeMDIChild).drwPaintPaint(nil);
   if frmLib<>nil then
   begin
      if frmLib.mListView<>nil then
      frmLib.mListView.Arrange(arDefault);
   end;
end;

procedure TfrmMain.FormShow(Sender: TObject);
var
  fileName:string;
  iCount:integer;
begin
  {增加窗口菜单项文件列表}
  iCount:=paramCount;
  if iCount>0 then
  begin
    fileName:=ParamStr(1);
    TfrmDrw.Create(fileName,false);
    createActionClient(ExtractFileName(fileName));
  end;
 OnShow :=nil;
end;

procedure TfrmMain.edit_TurnXExecute(Sender: TObject);
begin
  if ActiveMDIChild<>nil then
  TfrmDrw(ActiveMDIChild).Turn_X;
end;

procedure TfrmMain.edit_TurnYExecute(Sender: TObject);
begin
  if ActiveMDIChild<>nil then
  TfrmDrw(ActiveMDIChild).Turn_X;
end;

procedure TfrmMain.actPrintExecute(Sender: TObject);
begin
  if ActiveMDIChild<>nil then
  TfrmDrw(ActiveMDIChild).PrintObj;
end;

end.