myfun.pas

西门子Prodave6.0 的Delphi 版本, 需要安装 Prodave60软件,支持以太网通讯

               or ((Arow=1) and (aCol in [12,13,3]))
               or ((Arow=0) and (aCol in [13])) then
  begin
      canvas.Font.Color:=clwhite;
      Canvas.Brush.Color:=clGray;
      Canvas.FillRect(ARect);
   end;
    Canvas.TextRect(ARect, ARect.Left+2, ARect.Top+2, Cells[ACol, ARow]);
  inherited DrawCell(ACol, ARow, ARect, AState);
end;

{----------------------------------}
{重载SelectCell处理                }
{当某一个格被选中时。处理按键值发送}
function TvirtualKeyBoard.SelectCell(ACol, ARow: Integer): Boolean;
 var
  KeyStr:string;
  keyHex:word;
//  fn:Tfun;
begin
// Fn:=Tfun.Create(self);
 KeyStr:=cells[aCol,aRow];
 if assigned(FVkeyDown) then OnSelectCell(self,keyStr);
 if FSendHandle<>nil then
 begin
    if  KeyStr='' then keyHex:=0 else keyHex:=ord(keystr[1]);
      case  AnsiIndexStr(KeyStr,[',','.','↙','←']) of
        0:keyHex:=188;
        1:keyHex:=VK_DECIMAL;
        2:keyHex:=vk_return;//回车
        3:keyHex:=VK_Back;//退格键
      end;
      DoBleep(500,100);
      Fn.SendKey(FSendHandle.Handle,keyHex);
   end;
// fn.Free;
 result:=true
end;

procedure TvirtualKeyBoard.SetSendHandle(Control: TWinControl);
begin
   if FSendHandle <> Control then FSendHandle := Control;
end;

{==============================================================================}
{ TExEdit}
{将回车转为Tab}
{===============================================================================}
constructor TExEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  LabelPosition:= lpLeft;
end;
//------------------------------------------------------------------------------
procedure TExEdit.SetCaption(const Value: string);
begin
  FCaption := Value;
  self.EditLabel.Caption:=FCaption;
end;
//------------------------------------------------------------------------------
procedure TExEdit.SetOnlyInputNumber(Flag: Boolean);
begin
   if Flag<>FOnlyInputNumber then FOnlyInputNumber:=flag;
end;
//------------------------------------------------------------------------------
procedure TExEdit.WMKeyDown(var Message: Tmessage);
var
  vKey:string;
begin
  if message.WParam=VK_Return then Fn.SendKey(0,VK_TAB,vkeyClick);
 //---
 vkey:=copy(text,SelStart,1);//得到输入的字符
 if length(text)>0 then
 begin
  // if (message.WParam in [$41..$5A,$61..$7A,vk_space,187..189,191,226])and FOnlyInputNumber then
 //  begin
     (*再次过滤防止小键盘的按键被过滤*)
     if (vkey[1] in ['a'..'z','A'..'Z',' ','=',',','+','-','*','/','\']) and FOnlyInputNumber then
     begin
       self.SelStart:=self.SelStart-1;
       Fn.SendKey(self.Handle,VK_Delete);
       dobleep(800,100);
     end;
  // end;
 end; 
  if assigned(FKeyDown) then self.OnKeyDown(self,message.WParam);
  message.Result:=0;
//  Fn.Free;
end;

//------------------------------------------------------------------------------
// Tfun
//------------------------------------------------------------------------------
constructor TFun.Create(AOwner: TComponent);
begin
  inherited;
  SYSHintExDraw:=True;
end;
//------------------------------------------------------------------------------
procedure TFun.SetHintDraw(Flag:Boolean);
//var
 // DefHint:THintWindow;
begin
  SYSHintExDraw:=Flag;
  if SYSHintExDraw then
     HintWindowClass:=TIconHintX ////把我TIconHintX设置为默认的提示栏类:
  else
     HintWindowClass:=THintWindow //还原为系统默认的THintWindow
end;
//------------------------------------------------------------------------------
// 得到本机的ip地址
//------------------------------------------------------------------------------
function TFun.GetLocalIP: string;
type 
    TaPInAddr = array [0..10] of PInAddr;
    PaPInAddr = ^TaPInAddr; 
var
    phe  : PHostEnt;
    pptr : PaPInAddr;
    Buffer : array [0..63] of char;
    I    : Integer;
    GInitData      : TWSADATA;
begin
    WSAStartup($101, GInitData);
    Result := '';
    GetHostName(Buffer, SizeOf(Buffer));
    phe :=GetHostByName(buffer);
    if phe = nil then Exit;
    pptr := PaPInAddr(Phe^.h_addr_list);
    I := 0;
    while pptr^[I] <> nil do begin
      result:=StrPas(inet_ntoa(pptr^[I]^));
      Inc(I);
    end;
    WSACleanup;
end;
//==============================================================================
// TMyForm
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//==============================================================================
constructor TMyForm.Create(AOwner: TComponent);
begin
  inherited  Create(AOwner);
  FTitleNoActiveColor:=clSilver;
  FTitleActiveFontColor:=clWhite;
  FTitleActiveColor:=clGray;
  TempTitleColor:=FTitleActiveColor;
  //----
  FWinRectColor:=clGray;
  FWinRectLineWidth:=1;
  //------
  Font.Name:='宋体';
  Font.Size:=9;
  Font.Height:=-12;
  Font.Color:=clblack;
  Font.Charset:=GB2312_CHARSET;
  Color:=$00E2F3F3;//默认窗体颜色
  FCaption:='MyForm';
  height:=150;
  width:=250;
  BringToFront;
  SizeFlag:=false;
 //ullRepaint:=false;//关闭这个选项。防止放入没焦点的组件是出错
end;
//------------------------------------------------------------------------------
procedure TMyForm.DrawTitleButton;
begin
   //----关闭按钮---------
   Self.ShowHint:=False;
   canvas.Pen.Color:=clwhite;
   canvas.Rectangle(width-20,4,width-4,20);
   canvas.Font.Color:=FTitleActiveFontColor;
   canvas.TextOut(width-18,6,'╳');
   //----------最大化按钮------
   canvas.Rectangle(width-37,4,width-21,20);
   canvas.Font.Color:=FTitleActiveFontColor;
   canvas.TextOut(width-35,6,'□');
   //-------最小化铵钮------
   canvas.Rectangle(width-54,4,width-38,20);
   canvas.Font.Color:=FTitleActiveFontColor;
   canvas.TextOut(width-52,6,'─');
end;
//------------------------------------------------------------------------------
procedure TMyForm.Paint;
var
 // Fn:TFun;
  Rect:TRect;
begin
   inherited;
//   Fn:=TFun.Create(self);
   //标题栏范围
   Rect.Left:=3;
   Rect.Top:=3;
   rect.Bottom:=21;
   rect.Top:=3;
   rect.Right:=width-3;
   canvas.Brush.Color:=FTitleActiveColor;
   canvas.FillRect(rect);
   canvas.Rectangle(2,2,width-2,22);
   DrawTitleButton;//画title按钮
   //----画左和下边线
  // canvas.MoveTo(width-2,2);
  // canvas.LineTo(width-2,height-2);
  // canvas.LineTo(2,height-2);
  //---窗体标题
   canvas.Font.Color:=FTitleActiveFontColor;
   canvas.TextOut((width div 2) -(length(Fcaption) div 2)*5,6,Fcaption);
   Fn.DrawWindowRect(handle,FWinRectColor,FWinRectLineWidth);
 //  Fn.Free;
end;
//------------------------------------------------------------------------------
procedure TMyForm.setAutoBringTop(const Value: Boolean);
begin
  FAutoBringTop := Value;
end;

procedure TMyForm.SetCaption(str: string);
begin
  if FCaption<>Str then
  begin
    FCaption:=Str;
    Repaint;
  end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetTitleActiveColor(color: TCOlor);
begin
  if FTitleActiveColor<>Color then
  begin
    FTitleActiveColor:=Color;
    TempTitleColor:=FTitleActiveColor;
    Repaint;
  end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetTitleActiveFontColor(Color: TColor);
begin
   if FTitleActiveFontColor<>Color then
   begin
     FTitleActiveFontColor:=Color;
     Repaint;
   end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetTitleNoActiveColor(Value: TColor);
begin
  FTitleNoActiveColor := Value;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetWinRectColor(color: TColor);
begin
  if FwinRectColor<>color then
  begin
    FwinRectColor:=color;
    Repaint;
  end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetWinRectLineWidth(Lwidth: integer);
begin
  if FWinRectLinewidth<>Lwidth then
  begin
    FWinRectLinewidth:=Lwidth;
    Repaint;
  end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.WMLBUTTONDBLCLK(var message: TMessage);
begin
 if (message.LParamLo>1) and (message.LParamHi<20) then
 begin
  // if height>30 then
  if SizeFlag=false then
  begin
     sendmessage(Handle,WM_SYSCOMMAND,SC_MaxIMIZE,0);
     SizeFlag:=true;
  end else
  begin
    sendmessage(Handle,WM_SYSCOMMAND,SC_RESTORE,0);
     SizeFlag:=false;
  end;
 end;
 //if assigned(FClick) then self.OnClick(self);
end;
//------------------------------------------------------------------------------
procedure TMyForm.WMLMouseDown(var message: Tmessage);
var
  X,Y:integer;
begin
  X:=message.LParamLo;
  Y:=message.LParamHi;
 if assigned(FMouseDown) and(Y>23) then OnMouseDown(self,mbLeft,x,y);
 // OnMouseDown(self,mbLeft,ShiftState,x,y);//重载原OnMouseDown
 BringToFront; //有点击就将窗体提前
 if FSizeFlag<>SZNil then ReleaseCapture;
   case FSizeFlag of
     SZLeft: sendmessage(Handle,wm_Syscommand,sc_size or 1,0);
     SZRight:sendmessage(Handle,wm_Syscommand,sc_size or 2,0);
     SZTop:sendmessage(Handle,wm_Syscommand,sc_size or 3,0);
     SZBottom:sendmessage(Handle,wm_Syscommand,sc_size or 6,0);
     SZLeftTop:sendmessage(Handle,wm_Syscommand,sc_size or 4,0);
     SZRightTop: sendmessage(Handle,wm_Syscommand,sc_size or 5,0);
     SZLeftBottom:sendmessage(Handle,wm_Syscommand,sc_size or 8,0);
     SZRightBottom:sendmessage(Handle,wm_Syscommand,sc_size or 7,0);
   end;
 if (message.LParamLo>1) and (message.LParamHi<20) then
 begin
    sendmessage(Handle,wm_Syscommand,sc_Move or 2,0);
 end;
 //---------标题栏按钮处理-----------------
if (X<=width-4) and (X>=width-20) and
   (Y<=20) and (Y>=4) then
begin
  if assigned(FCLose) then OnClose(self);
  Hide;
end;
  //----------最大化按钮------
if (X<=width-21) and (X>=width-37) and
   (Y<=20) and (Y>=4)
then begin
  if SizeFlag=false then
  begin
     sendmessage(Handle,WM_SYSCOMMAND,SC_MaxIMIZE,0);
     SizeFlag:=true;
  end else
  begin
    sendmessage(Handle,WM_SYSCOMMAND,SC_RESTORE,0);
     SizeFlag:=false;
  end;
end;
//------------------
if (X<=width-38) and (X>=width-54) and
   (Y<=20) and (Y>=4)
then sendmessage(handle,WM_SYSCOMMAND,SC_MINIMIZE,0);
//if assigned(FMouseDown) then self.OnMouseDown(self,mbLeft,shift,X,y);
end;
//------------------------------------------------------------------------------
procedure TMyForm.WmLMouseUp(var message: Tmessage);
begin
  if assigned(FMouseUp)and(message.LParamHi>23) then onMouseUP(self,mbLeft,message.LParamLo,message.LParamHi);
   if assigned(FClick)and(message.LParamHi>23) then onClick(self);//onclick事件
end;
//------------------------------------------------------------------------------
procedure TMyForm.WMMouseEnter(var Message: TMessage);
begin
 if FAutoBringTop then self.BringToFront;//用户设置是否自动提前
 if assigned(FMouseEnter) then OnMouseEnter(self);
   FTitleActiveColor:=TempTitleColor;
   self.Repaint;
end;