📄 dldw.~pas

📁 这是用Delphi编写的中小企业管理系统
💻 ~PAS
字号:
unit dldw;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ExtCtrls, jpeg, DB, ADODB, Grids, DBGrids,
  StdCtrls;

type
  Tf_dldw = class(TForm)
    entireimage: TImage;
    PopupMenu1: TPopupMenu;
    N10: TMenuItem;
    N11: TMenuItem;
    Timer1: TTimer;
    khxxGrid: TDBGrid;
    DataSource1: TDataSource;
    tsxx: TMemo;
    ADOQuery1: TADOQuery;
    ADOQuery2: TADOQuery;
    procedure FormShow(Sender: TObject);
    Procedure AddShape(x,y: Integer;Hint: String;Tag: Integer);
    procedure N10Click(Sender: TObject);
    procedure entireimageMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormConstrainedResize(Sender: TObject; var MinWidth,
      MinHeight, MaxWidth, MaxHeight: Integer);
    procedure Timer1Timer(Sender: TObject);
    procedure khxxGridDblClick(Sender: TObject);
    procedure entireimageClick(Sender: TObject);
    procedure entireimageMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure entireimageDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure Shape1EndDrag(Sender, Target: TObject; X, Y: Integer);
    procedure N11Click(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private declarations }
  public
    procedure ShapeMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    { Public declarations }
    Function MakeTag: Integer; //自动生成Tag
    Function FormContainShape: Boolean; //判断窗体中是否包含TShape组件
  end;
  khxx = record
    khdm: String;//客户编号
    khmc: String;//客户名称
    fzr: String;//负责人
    ksb: String;//课税别
    wz: String;//网址
    hint: String;//提示信息
    x: integer;
    y: integer;
    tag: Integer;
  end;
var
  f_dldw: Tf_dldw;
  arrkhxx: khxx;
  x1: Integer = 0; //记录表格出现的位置
  y1: Integer = 0; //...
  FormWidth: Integer = 0;
  FormHeight: Integer = 0;
  bl: ReaL = 1.0;//图片宽度与窗体宽度的比
  Drag: Boolean = False;//确定是否拖动图标
  Dragx: Integer = 0;
  Dragy: Integer = 0;
  Movetag: Integer = -1;//鼠标在TShape组件上移动时,记录TShape组件的Tag属性,用于删除操作
implementation
{$R *.dfm}

procedure Tf_dldw.AddShape(x,y: Integer;Hint: String;tag: Integer);
var
  Shape: TShape;
begin
  Try
    Shape := TShape.Create(nil);
    Shape.Parent := self;
    Shape.Pen.Color := clblue;
    Shape.Pen.Width := 3;
    Shape.Width := 30;
    Shape.Height := 30;
    Shape.Tag := Tag;
    Shape.Shape := stCircle;
    Shape.Brush.Style := bsClear;
    Shape.OnEndDrag := Shape1EndDrag;
    Shape.DragMode := dmAutomatic;
    Shape.OnMouseMove := ShapeMouseMove;
    Shape.Left := (EntireImage.Left)+x-Trunc(Shape.Width/2);
    Shape.Top := (EntireImage.Top)+y-Trunc(Shape.Height/2);
    Shape.Show;
  Except
    Application.MessageBox('添加标记失败.','提示',64);
  End;
end;

procedure Tf_dldw.FormShow(Sender: TObject);
begin
  if FileExists(extractFilePath(Application.ExeName)+'map\changchun.jpg') = True then
    EntireImage.Picture.LoadFromFile(extractFilePath(Application.ExeName)+'\map\changchun.jpg')
  else
    Application.MessageBox('图片文件不存在.','提示',64);
  EntireImage.Left := 0;
  EntireImage.Top := 0;
  with ADOQuery1 do
  begin
    Close;
    SQL.Clear;
    SQL.Add('select a.*,b.khmc,b.fzr,b.ksb,b.wz from t_khdldw a inner join t_khzl b on a.khdm = b.khdm ');
    Open;
  end;
  if ADOQuery1.RecordCount>0 then
  begin
    while Not ADOQuery1.Eof do
    begin
      arrkhxx.khdm := Trim(ADOQuery1.FieldByName('khdm').AsString);
      arrkhxx.x := ADOQuery1.FieldByName('x').AsInteger;
      arrkhxx.y := ADOQuery1.FieldByName('y').AsInteger;
      arrkhxx.tag := ADOQuery1.FieldByName('tag').AsInteger;
      arrkhxx.fzr := Trim(ADOQuery1.FieldByName('fzr').AsString);
      arrkhxx.ksb := Trim(ADOQuery1.FieldByName('ksb').AsString);
      arrkhxx.wz := Trim(ADOQuery1.FieldByName('wz').AsString);
      arrkhxx.hint := Trim(ADOQuery1.FieldByName('hint').AsString);
      AddShape(arrkhxx.x,arrkhxx.y,arrkhxx.hint,Arrkhxx.tag);
      ADOQuery1.Next;
    end;
  end;
end;

procedure Tf_dldw.N10Click(Sender: TObject);
var
  GridLeft,GridTop: Integer;
begin
  with ADOQuery2 do
  begin
    Close;
    SQL.Clear;
    SQL.Add('Select b.khdm,b.khmc,b.fzr,b.ksb,b.wz from t_khzl b where b.khdm not in(select khdm from t_khdldw)');
    Open;
  end;
  if ADOQuery2.RecordCount>0 then
  begin
    GridLeft:= EntireImage.Left+ x1;
    GridTop:= EntireImage.Top+ y1;
    if (GridLeft + khxxGrid.Width)>Width then
      GridLeft := GridLeft - khxxGrid.Width;
    if (GridTop + khxxGrid.Height) >Height then
      GridTop := GridTop - khxxGrid.Height;
    DataSource1.DataSet := ADOQuery2;
    KhxxGrid.Left := GridLeft;
    KhxxGrid.Top := GridTop;
    KhxxGrid.Visible := True;
  end
  else
  begin
    KhxxGrid.Visible := False;
    DataSource1.DataSet := Nil;
    Application.MessageBox('当前没有可定位的客户资料.','提示',64);
  end;
end;

procedure Tf_dldw.entireimageMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  x1 := x;
  y1 := y;
end;

procedure Tf_dldw.FormConstrainedResize(Sender: TObject; var MinWidth,
  MinHeight, MaxWidth, MaxHeight: Integer);
begin
  MaxWidth := EntireImage.Width;
  MaxHeight := EntireImage.Height;
end;

procedure Tf_dldw.Timer1Timer(Sender: TObject);
var
  i: Integer;
begin
  For i := 0 to ControlCount-1 do
    if Controls[i] is TShape then
    begin
     if  TShape(Controls[i]).Pen.Color = clBlue then
        TShape(Controls[i]).Pen.Color := clRed
     else if TShape(Controls[i]).Pen.Color = clRed then
        TShape(Controls[i]).Pen.Color := clBlue;
    end;
end;

procedure Tf_dldw.khxxGridDblClick(Sender: TObject);
var
  Hint: String;
  shapeTag: Integer;
begin
   Hint := '客户代码: '+Trim(ADOQuery2.FieldByName('khdm').AsString)+' ; 客户名称: '+
    Trim(ADOQuery2.FieldByName('khmc').AsString)+ ' ; 负责人: '+Trim(ADOQuery2.FieldByName('fzr').AsString)+
    ' ; 课税别: '+ Trim(ADOQuery2.FieldByName('ksb').AsString)+ ' ; 网址: '+ Trim(ADOQuery2.FieldByName('wz').AsString);
  ShapeTag := MakeTag;
  AddShape(x1,y1,Hint,ShapeTag);
  Try
    With ADOQuery1 do
    begin
      Close;
      SQL.Clear;
      SQL.Add('Insert t_khdldw values (:a,:b,:c,:d,:e)');
      Parameters.ParamByName('a').Value := Trim(ADOQuery2.FieldByName('khdm').AsString);
      Parameters.ParamByName('b').Value := x1;
      Parameters.ParamByName('c').Value := y1;
      Parameters.ParamByName('d').Value := ShapeTag;
      Parameters.ParamByName('e').Value := Trim(Hint);
      ExecSQL;
    end;
    khxxGrid.Visible := False;
    Application.MessageBox('操作成功.','提示',64);
  Except
    Application.MessageBox('操作失败.','提示',64);
  end;
end;

procedure Tf_dldw.entireimageClick(Sender: TObject);
begin
  if khxxGrid.Visible = True then
    KhxxGrid.Visible := False;
  Drag := False;
end;

procedure Tf_dldw.ShapeMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  tsxxLeft,tsxxTop: Integer;
  Rect: TRect;
begin
  if Drag = False then
  begin
    Rect := GetClientRect;
    if Sender is TShape then
    begin
      Movetag := TShape(Sender).Tag;
      tsxxLeft:= TShape(Sender).Left+TShape(Sender).Width;
      tsxxTop:= TShape(Sender).Top-Trunc((tsxx.Height-TShape(Sender).Height)/2);
      if (tsxxTop + tsxx.Height)>=(Rect.Top+Rect.Bottom) then
      begin
        tsxxTop := TShape(Sender).Top - tsxx.Height;
        tsxxLeft := tsxxLeft-Trunc(tsxx.Width/2)-Trunc(TShape(Sender).Width/2);
        if tsxxLeft+EntireImage.Left <0 then
          tsxxLeft :=TShape(Sender).Left+ TShape(Sender).Width
        else if (tsxxLeft+tsxx.Width) >= (Rect.Left+Rect.Right)then
          tsxxLeft := tsxxLeft-Trunc(tsxx.Width/2)-Trunc(TShape(Sender).Width/2);
      end
      else if tsxxTop <=0 then
      begin
        tsxxTop := TShape(Sender).Top + TShape(Sender).Height;
        tsxxLeft := tsxxLeft-Trunc(tsxx.Width/2)-Trunc(TShape(Sender).Width/2);
        if tsxxLeft+EntireImage.Left < 0 then
          tsxxLeft :=TShape(Sender).Left+ TShape(Sender).Width
        else if (tsxxLeft+tsxx.Width) >(Rect.Left+Rect.Right)then
          tsxxLeft := TShape(Sender).Left - tsxx.Width;
      end
      else
      begin
        if tsxxLeft+EntireImage.Left <= 0 then
          tsxxLeft :=TShape(Sender).Left+ TShape(Sender).Width
        else if (tsxxLeft+tsxx.Width) >= (Rect.Left+Rect.Right)then
          tsxxLeft := TShape(Sender).Left - tsxx.Width;
      end;
      with ADOQuery1 do
      begin
        Close;
        SQL.Clear;
        SQL.Add('select Hint from t_khdldw where tag = :a');
        Parameters.ParamByName('a').Value := TShape(Sender).Tag;
        Open;
      end;
      if ADOQuery1.RecordCount> 0 then
      begin
        tsxx.Text := Trim(ADOQuery1.FieldByName('Hint').Value);
        tsxx.Left := tsxxLeft;
        tsxx.Top := tsxxTop;
        tsxx.Show;
      end;
    end;
  end;
end;

function Tf_dldw.MakeTag: Integer;
var
  min,max,mid: Integer;
begin
  Result := -1;
  with ADOQuery1 do
  begin      
    Close;
    SQL.Clear;
    SQL.Add('Select min(tag) from t_khdldw');
    Open;
  end;
  if ADOQuery1.Fields[0].AsInteger = Null then
  begin
    Result := 1;
  end
  else
  begin
    Min := ADOQuery1.Fields[0].AsInteger;
    with ADOQuery1 do
    begin
      Close;
      SQL.Clear;
      SQL.Add('Select Max(tag) from t_khdldw');
      Open;
    end;
    Max :=  ADOQuery1.Fields[0].AsInteger;
    if (Max = Min)or(Max-min =1) then
    begin
      Result := Max+1;
    end
    else
    begin
      For mid := min+1 to Max-1 do
      begin
        with ADOQuery1 do
        begin
          Close;
          SQL.Clear;
          SQL.Add('Select * from t_khdldw where tag = :a');
          Parameters.ParamByName('a').Value := mid;
          Open;
        end;
        if ADOQuery1.RecordCount<1 then
        begin
          Result := Mid;
          Exit;
        end
        else if mid = Max-1  then
        begin
          Result := Max+1;
        end;
      end;
    end;
  end;
end;

procedure Tf_dldw.entireimageMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
  tsxx.Visible := False;
  MoveTag := -1;
end;

procedure Tf_dldw.entireimageDragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
begin
  if Source is TShape then
  begin
    if Drag = True then
    begin
     Dragx := x;
     Dragy := y;
     TShape(Source).Left := EntireImage.Left+x;
     TShape(Source).Top := EntireImage.Top+y ;
    end
  else
    TShape(Sender).EndDrag(True);
  end;
end;

procedure Tf_dldw.Shape1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
  if Sender is TShape then
  begin
    Try
      with ADOQuery1 do
      begin
        Close;
        SQL.Clear;
        SQL.Add('Update t_khdldw set x = :a,y = :b where Tag = :c');
        Parameters.ParamByName('a').Value := TShape(Sender).Left+ Trunc(TShape(Sender).Width/2)-EntireImage.Left;
        Parameters.ParamByName('b').Value := TShape(Sender).Top + Trunc(TShape(Sender).Height/2)-EntireImage.Top;
        Parameters.ParamByName('c').Value := TShape(Sender).Tag;
        ExecSQL;
      end;
    Except
    end;
    Drag := False;
  end;
end;

procedure Tf_dldw.N11Click(Sender: TObject);
begin
  if FormContainShape = True then
  begin
    if Application.MessageBox('确实要更改客户地理位置吗?','提示',mb_YesNo)= ID_Yes then
      Drag := True
    else
      Drag := False;
  end;
end;

function Tf_dldw.FormContainShape: Boolean;
var
  i: Integer;
begin
  Result := False;
  For i := 0 to ControlCount-1 do
    if Controls[i] is TShape then
    begin
      Result := True;
      Break;
    end;
end;


procedure Tf_dldw.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  i: Integer;
begin
  if (Key = vk_Delete) then
    if  MoveTag<>-1 then
    begin
      if Application.MessageBox('确实要删除当前客户地理信息吗?','提示',mb_YesNo)= ID_Yes then
      begin
        Try
          with ADOQuery1 do
          begin
            Close;
            SQL.Clear;
            SQL.Add('delete t_khdldw where tag = :a');
            Parameters.ParamByName('a').Value := Movetag;
            ExecSQL;
          end;
          For i := 0 to ControlCount-1 do
          begin
            if Controls[i] is TShape then
              if TShape(Controls[i]).Tag = MoveTag then
              begin
                TShape(Controls[i]).Free;
                Break;
              end;
          end;
          Application.MessageBox('删除成功.','提示',64);
        Except
          Application.MessageBox('删除失败.','提示',64);
        End;
      end;
    end
    else
      Application.MessageBox('请指定欲删除客户信息.','提示',64);
end;

end.
💿 文件大小 8389 K
👤 上传用户 xushenghao001
📂 所属分类企业管理
🏷️ 相关标签

#Delphi #编写 #企业管理
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -