freepicu.pas

矢量图形绘制

            11: begin
                    Image1.Cursor := 8;
                end;
        end;
        if (SelPic is TTextPic) then begin
            atext.Keyval := 27;
            if TTextPic(SelPic).EditShowing then TTextPic(SelPic).Text := atext;
        end;
        case Image1.Cursor of
            CURSOR_LINE: SelPic := LinePic;
            CURSOR_RECT: SelPic := RectPic;
            CURSOR_ROUN: SelPic := RounPic;
            CURSOR_CIRC: SelPic := CircPic;
            CURSOR_ARCC: SelPic := ArccPic;
            CURSOR_POLY: SelPic := PolyPic;
            CURSOR_CURVE: SelPic := CurvePic;
            CURSOR_TEXT: SelPic := TextPic;
        end;
    end else begin
        if (SelPic is TTextPic) then begin
            atext.Text := TTextPic(SelPic).EditText;
            if atext.Text <> '' then atext.Keyval := 13 else atext.Keyval := 27;
            if TTextPic(SelPic).EditShowing then TTextPic(SelPic).Text := atext;
        end;
        if PicList.Count > 0 then SelPic := TPicBase(PicList.Items[PicList.Count - 1]) else SelPic := nil;
        Image1.Cursor := CURSOR_ARROW;
    end;
    GetImageCanvasBmp(False, True);
end;

procedure TFreePicF.GetImageCanvasBmp(DisChoose: Boolean; DrawToImage: Boolean);
var
    I1: Integer;
begin
    OffSrc.Canvas.Brush.Color := RGB(100,0,100);
    OffSrc.Canvas.FillRect(Rect(0, 0, OffSrc.Width, OffSrc.Height));
    for I1 := 0 to PicList.Count - 1 do begin
        if DisChoose then TPicBase(PicList.Items[I1]).Choosed := False;
        TPicBase(PicList.Items[I1]).DrawPic(OffSrc.Canvas);
    end;
    if DrawToImage then Image1.Canvas.Draw(0, 0, OffSrc);
end;

function TFreePicF.GetMousePos(mp: TPoint; var index: Integer): MOUSE_POS;
var
    I1: Integer;
    rpos: MOUSE_POS;
begin
    Result := POS_OUT;
    if SelPic <> nil then begin
        if SelPic.PicIndex <> -1 then begin
            rpos := SelPic.MouseInPicRegion(Image1.Canvas, mp);
            if rpos <> POS_OUT then begin
                Result := rpos;
                index := SelPic.PicIndex;
                Exit; //返回
            end;
        end;
    end;
    for I1 := PicList.Count - 1 downto 0 do begin
        rpos := TPicBase(PicList.Items[I1]).MouseInPicRegion(Image1.Canvas, mp);
        if rpos <> POS_OUT then begin
            Result := rpos;
            index := TPicBase(PicList.Items[I1]).PicIndex;
            Break;
        end;
    end;
end;

procedure TFreePicF.Image1MouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
var
    atext: TTextInfo;
    pindex: Integer;
begin
    mouseDownOldX := X;
    mouseDownOldY := Y;
    mouseOldX := X;
    mouseOldY := Y;
    if (SelPic is TTextPic) then begin
        if (Image1.Tag = 0) then begin
            atext.Text := TTextPic(SelPic).EditText;
            if TTextPic(SelPic).InputMode then begin
                if atext.Text <> '' then atext.Keyval := 13 else atext.Keyval := 27;
            end;
            if TTextPic(SelPic).EditMode then atext.Keyval := 27;
            if TTextPic(SelPic).EditShowing then TTextPic(SelPic).Text := atext;
        end else Image1.Tag := 0;
    end;
    case Image1.Cursor of
        CURSOR_LINE..CURSOR_TEXT:
            begin
                if (SelPic is TPolyPic) then begin
                    if not (TPolyPic(SelPic).PicState) then GetImageCanvasBmp(True, True);
                end else begin
                    GetImageCanvasBmp(True, True);
                end;
                SelPic.Choosed := False;
                SelPic.ParentMouseDown(Image1.Canvas, Image1.Cursor, Button, Shift, Point(X, Y));
            end;
    else
        begin
            mousePos := GetMousePos(Point(X, Y), pindex);
            if mousePos = Pos_Center then begin
                GetImageCanvasBmp(True, True);
                SelPic := TPicBase(PicList.Items[pindex]);
                SelPic.Choosed := True;
                SelPic.DrawFocusRect(Image1.Canvas);
            end;
        end;
    end;
    SetCapture(TWinControl(Image1).Handle); //捕捉所有的鼠标输入 mouseUp时释放
end;

procedure TFreePicF.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
    Y: Integer);
var
    pindex: Integer;
    picCursor: TCursor;
    procedure GetPicParentCursor;
    begin
        picCursor := crArrow; //箭头
        mousePos := GetMousePos(Point(X, Y), pindex);
        case mousePos of
            //矩形顶点
            POS_LEFTTOP: picCursor := crSizeNWSE; //左上
            POS_RIGHTTOP: picCursor := crSizeNESW; //右上
            POS_RIGHTBOTTOM: picCursor := crSizeNWSE; //右下
            POS_LEFTBOTTOM: picCursor := crSizeNESW; //左下
            //矩形的边中点
            POS_CENTERTOP: picCursor := crSizeNS; //上中
            POS_RIGHTCENTER: picCursor := crSizeWE; //右中
            POS_CENTERBUTTOM: picCursor := crSizeNS; //下中
            POS_LEFTCENTER: picCursor := crSizeWE; //左中
            Pos_Center: picCursor := crSize; //矩形中央
            //直线端点
            POS_LINESTART: picCursor := CURSOR_LINE_END; //直线起点 1999.1.12
            POS_LINEEND: picCursor := CURSOR_LINE_END; //直线终点 1999.1.12
            POS_ROUNDRECT_TOP: picCursor := CURSOR_TRUN_VER; //圆角矩形的上圆角点
            POS_ROUNDRECT_LEFT: picCursor := CURSOR_TRUN_VER; //圆角矩形的左圆角点
            POS_ARCSTART: picCursor := CURSOR_TRUN_VER; //圆弧的起点
            POS_ARCEND: picCursor := CURSOR_TRUN_VER; //圆弧的终点
            POS_POLYPOINT: picCursor := CURSOR_TRUN_VER; //多边形顶点
            POS_CURVEPOINT: picCursor := CURSOR_TRUN_VER; //多边形顶点
        end;
        Image1.Cursor := picCursor;
    end;
begin
    case Image1.Cursor of
        CURSOR_LINE..CURSOR_TEXT:
            begin
                SelPic.ParentMouseMove(Image1.Canvas, Image1.Cursor, Shift, Point(X, Y));
            end;
        CURSOR_ARROW:
            begin
                if (ssLeft in Shift) then Exit;
                GetPicParentCursor;
            end;
    else
        begin
            if (ssLeft in Shift) then begin
                if Ord(mousePos) > 0 then begin
                    if SelPic = nil then Exit;
                    SelPic.PicChangeing(Image1.Canvas, mousePos, SelPic.PicRect,
                        mouseDownOldX, mouseDownOldY, mouseOldX, mouseOldY, X, Y);
                end;
                mouseOldX := X;
                mouseOldY := Y;
            end else begin
                GetPicParentCursor;
            end;
        end;
    end;
end;


procedure TFreePicF.Image1MouseUp(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
begin
    case Image1.Cursor of
        CURSOR_LINE..CURSOR_TEXT:
            begin
                SelPic.Choosed := True;
                SelPic.ParentMouseUp(Image1.Canvas, Image1.Cursor, Button, Shift, Point(X, Y));
            end;
        CURSOR_ARROW:
            begin
                SelPic := nil;
                GetImageCanvasBmp(True, True);
            end;
    else
        begin
            if Button = mbLeft then begin
                if SelPic = nil then Exit;
                SelPic.PicChangedUpdate(Image1.Canvas, mousePos, SelPic.PicRect, mouseDownOldX, mouseDownOldY, X, Y);
                GetImageCanvasBmp(False, True);
            end else begin
                if SelPic = nil then Exit;
                if (SelPic is TTextPic) then begin
                    N1.Enabled := False;
                    N2.Enabled := False;
                    X1.Enabled := False;
                    N11.Enabled := True;
                    G1.Enabled := True;
                end else begin
                    N1.Enabled := True;
                    N2.Enabled := True;
                    X1.Enabled := True;
                    N11.Enabled := False;
                    G1.Enabled := False;
                    if ((SelPic is TLinePic) or (SelPic is TPolyPic)) then N6.Enabled := False else N6.Enabled := True;
                    if (SelPic is TArccPic) then begin
                        if TArccPic(SelPic).PicArccType = ARCC_ARC then N6.Enabled := False else N6.Enabled := True;
                    end;
                end;
                PicMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
            end;
        end;
    end;
    ReleaseCapture; //释放鼠标
end;


procedure TFreePicF.N1Click(Sender: TObject);
var
    linew: Integer;
begin
    linew := SelPic.PicPen.Width;
    if ShowSetLineWidthForm(linew) then begin
        SelPic.PicPen.Width := linew;
        GetImageCanvasBmp(False, True);
    end;
end;

procedure TFreePicF.N20Click(Sender: TObject);
begin
    case TMenuItem(Sender).Tag of
        1: SelPic.PicPen.Style := psSolid;
        2: SelPic.PicPen.Style := psDash;
        3: SelPic.PicPen.Style := psDot;
        4: SelPic.PicPen.Style := psDashDot;
        5: SelPic.PicPen.Style := psDashDotDot;
    end;
    GetImageCanvasBmp(False, True);
end;


procedure TFreePicF.N3Click(Sender: TObject);
begin
    case TMenuItem(Sender).Tag of
        1: SelPic.PicPen.Color := clRed;
        2: SelPic.PicPen.Color := clLime;
        3: SelPic.PicPen.Color := clYellow;
    end;
    GetImageCanvasBmp(False, True);
end;


procedure TFreePicF.N10Click(Sender: TObject);
begin
    case TMenuItem(Sender).Tag of
        1: SelPic.PicBrush.Style := bsClear;
        2: SelPic.PicBrush.Color := clRed;
        3: SelPic.PicBrush.Color := clLime;
        4: SelPic.PicBrush.Color := clYellow;
    end;
    if TMenuItem(Sender).Tag <> 1 then SelPic.PicBrush.Style := bsSolid;
    GetImageCanvasBmp(False, True);
end;

procedure TFreePicF.N26Click(Sender: TObject);
begin
    case TMenuItem(Sender).Tag of
        1: SelPic.PicBrush.Style := bsCross;
        2: SelPic.PicBrush.Style := bsDiagCross;
        3: SelPic.PicBrush.Style := bsHorizontal;
        4: SelPic.PicBrush.Style := bsVertical;
        5: SelPic.PicBrush.Style := bsBDiagonal;
        6: SelPic.PicBrush.Style := bsFDiagonal;
    end;
    GetImageCanvasBmp(False, True);
end;


procedure TFreePicF.N11Click(Sender: TObject);
var
    aTextInfo: TTextInfo;
    FontDialog: TFontDialog;
begin
    FontDialog := TFontDialog.Create(nil);
    try
        FontDialog.Font.Assign(SelPic.PicFont);
        if FontDialog.Execute then begin
            SelPic.PicFont.Assign(FontDialog.Font);
            aTextInfo.Keyval := 13;
            aTextInfo.Text := TTextPic(SelPic).Text.Text;
            TTextPic(SelPic).Text := aTextInfo;
            GetImageCanvasBmp(False, True);
        end;
    finally
        FontDialog.Free;
    end;
end;

procedure TFreePicF.N3D1Click(Sender: TObject);
begin
    case TMenuItem(Sender).Tag of
        1: begin
                TTextPic(SelPic).Hollow := False;
                TTextPic(SelPic).Sided := False;
                TTextPic(SelPic).View3D := False;
            end;
        2: TTextPic(SelPic).Hollow := True;
        3: TTextPic(SelPic).Sided := True;
        4: TTextPic(SelPic).View3D := True;
    end;
    GetImageCanvasBmp(False, True);
end;

procedure TFreePicF.SpeedButton4Click(Sender: TObject);
var
    mIndex: Integer;
    mLinePic: TLinePic;
    mRectPic: TRectPic;
    mRounPic: TRounPic;
    mCircPic: TCircPic;
    mArccPic: TArccPic;
    mPolyPic: TPolyPic;
    mCurvePic: TCurvePic;
    mTextPic: TTextPic;
    procedure ChangPicListItemIndex;
    var
        I: Integer;
    begin
        for I := 0 to PicList.Count - 1 do TPicBase(PicList.Items[I]).PicIndex := I;
        GetImageCanvasBmp(False, True);
    end;
    procedure ChangPicListSelect;
    var
        I: Integer;
    begin
        for I := 0 to PicList.Count - 1 do TPicBase(PicList.Items[I]).Choosed := False;
    end;
begin
    case TSpeedButton(Sender).Tag of
        1: begin
                if SelPic <> nil then begin
                    if SelPic.PicIndex >= 0 then CopyPic := SelPic;
                end;
            end;
        2: begin
                if SelPic <> nil then begin
                    CopyPic := SelPic;
                    mIndex := SelPic.PicIndex;
                    TPicBase(PicList.Items[mIndex]).Free; ;
                    SelPic := nil;
                    ChangPicListItemIndex;