myfun.pas

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

    imm:=imm+iss div 60;
    if iss>=60 then iss:=iss-60;
    ihh:=ihh+imm div 60;
    if ihh>=24 then  DayCount:=round(ihh/24);
    if ihh>=12 then ihh:=ihh-12*round(ihh/12);
  result:=strTotime(format('%.2d:%.2d:%.2d',[ihh,imm,iss]))
end;
//------------------------------------------------------------------------------
// 
//------------------------------------------------------------------------------

{--------------}
{精确毫秒级延时}
{--------------}
procedure TFun.TimeDelay(DT: Dword);
var
  TT:Dword;
begin
  TT:=GetTickCount;
  while getTickCount-TT<DT do
  application.ProcessMessages;//防止死锁
end;
//______________________________________________________________________________

{-------------------}
{  设定网络Ip地址   }
{-------------------}
procedure TFun.SetIPaddress(SIP: TNetValue;const isAuto:boolean);
var
  reg:Tregistry;
begin
  reg:=Tregistry.Create;
  reg.RootKey:=HKEY_LOCAL_MACHINE;
  if reg.OpenKey('\SYSTEM\ControlSet001\Services\{6CF72061-4BB8-47D6-96CD-76886198826A}\Parameters\Tcpip',true) then
  begin
    if not isAuto then
    begin
       reg.WriteString('IpAddress',sIP.IpAddress);
       reg.WriteString('SubnetMask',sIP.SubnetMask);
       reg.WriteString('DefaultGateway',sIP.DefaultGateway);
       reg.WriteBool('EnableDHCP',false);
    end else
    begin
       reg.WriteBool('EnableDHCP',true);
       reg.WriteString('IpAddress','0.0.0.0');
    end;
  end;
  reg.CloseKey;
  reg.Free;
end;
//______________________________________________________________________________

{----------------------------------}
{得到memo的行号，当前位置，行长度等}
{----------------------------------}
procedure TFun.GetMemoMousePos(m: Tmemo;var posValue:TmemoPos);
begin
  posValue.LinePos:=sendmessage(m.Handle,EM_LINEFROMCHAR,m.SelStart,0);//得到行号
  posValue.CharPos:=sendmessage(m.Handle,EM_LINEINDEX,posValue.LinePos,0);//得到字符位置
  posValue.lineLenght:=sendmessage(m.Handle,EM_LINELENGTH,posValue.CharPos,0);//得到长的长度
end;
{重载RichEdit对像处理}
procedure TFun.GetMemoMousePos(m:TRichEdit;var posValue:TmemoPos);
begin
  posValue.LinePos:=sendmessage(m.Handle,EM_LINEFROMCHAR,m.SelStart,0);//得到行号
  posValue.CharPos:=sendmessage(m.Handle,EM_LINEINDEX,posValue.LinePos,0);//得到字符位置
  posValue.lineLenght:=sendmessage(m.Handle,EM_LINELENGTH,posValue.CharPos,0);//得到长的长度
end;
//______________________________________________________________________________
//Memo翻页
procedure TFun.setScrollPos(MHandle: Thandle; const pos: TClickType);
begin
  if pos=pageDown then
    SendMessage(MHandle,wm_Keydown,Vk_next,-1)
  else
    SendMessage(MHandle,wm_KeyUp,Vk_next,-1)
end;
//______________________________________________________________________________
{------------------------}
{   打开和关闭显示器     }
{      for  win9x        }
{------------------------}
procedure TFun.DisplayOFFON(SW: boolean);
begin
  if SW then
    (*打开显示器*)
     SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,-1)
  else
    (*关闭显示器*)
    SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,0)
end;
//______________________________________________________________________________
{-------------------}
{  显示和隐藏桌面   }
{-------------------}
procedure TFun.HideDesktop(sw: Boolean);
begin
  if sw then
    (*显示*)
    showWindow(findwindow('Progman',nil),sw_Show)
  else
    (*隐藏*)
     showWindow(findwindow('Progman',nil),sw_Hide)
end;
//______________________________________________________________________________
{-----------------------}
{  同时隐藏桌面和任务栏 }
{-----------------------}
procedure TFun.HideDesktopAndTaskBar(sw: Boolean);
begin
    HideTaskBar(SW);//关闭和打开显示器
    HideDesktop(sw);//显示和隐藏桌面
end;
//______________________________________________________________________________

{屏蔽ALT+F4和ALT+Ctrl+Del}
{      仅用于win9X       }
procedure TFun.DisbleQuikKey(sw: boolean);
var
  temp,iC:integer;
begin
  if sw then iC:=0 else iC:=1;
  //iC=1为屏蔽,0为恢复
 SystemParametersInfo(Spi_screensaverrunning,iC,@temp,0);
end;
//______________________________________________________________________________
{---------------------------------}
{       让程序只运行一次          }
{---------------------------------}
Function  TFun.AppRunOnce:Boolean;
var
  HW:Thandle;
  sClassName,sTitle:string;
begin
  sClassName:=application.ClassName;
  sTitle:=application.Title;
  application.Title:='F982D120-BA1E-4199-8FBD-F4EED2F6E8A7'; //更改当前app标题
  HW:=findwindow(pchar(sClassName),pchar(sTitle));
  (*如果发现已有实例在运行，则关闭自己*)
  if HW<>0 then application.Terminate;
  application.Title:=sTitle; //恢复app标题
  result:=Hw<>0 //存在则返回true,无返回false
end;
//______________________________________________________________________________
{----------------------------}
{判断字符串是不是有效数字字符}
{----------------------------}
function TFun.IsStrAsNumber(NumStr:string):Bool;
var
  i:integer;
begin
  result:=True;
  if not (Numstr[1] in ['1','2','3','4','5','6','7','8','9']) then
  begin
    {首位为0，或者是其他的非数字字符，则提前返回false}
    result:=false;
    exit
  end;
//--------------
  for i:=1 to length(NumStr) do
  begin
    if not (Numstr[i] in ['0','1','2','3','4','5','6','7','8','9']) then
    begin
      result:=false;
      exit
    end;
  end;(* for i:=1 to length(NumStr) do*)
end;
//______________________________________________________________________________
{-----------------}
{ 如：发送ALT+F  }
{-----------------}
procedure TFun.SendComBoKey(const CtrlKey, FnKey: word);
begin
  keybd_event(CtrlKey, MapVirtualKey(CtrlKey, 0),0,0);
  keybd_event(FnKey, MapVirtualKey(FnKey, 0),0,0);
  keybd_event(FnKey, MapVirtualKey(FnKey, 0),KEYEVENTF_KEYUP,0);
  keybd_event(CtrlKey, MapVirtualKey(CtrlKey, 0),KEYEVENTF_KEYUP,0);
end;
//______________________________________________________________________________
{------------------------}
{  得到汉字的首字母      }
{------------------------}
function TFun.GetPYIndexChar( hzchar:string):char;
begin
  case WORD(hzchar[1]) shl 8 + WORD(hzchar[2]) of
    $B0A1..$B0C4 : result := 'A';
    $B0C5..$B2C0 : result := 'B';
    $B2C1..$B4ED : result := 'C';
    $B4EE..$B6E9 : result := 'D';
    $B6EA..$B7A1 : result := 'E';
    $B7A2..$B8C0 : result := 'F';
    $B8C1..$B9FD : result := 'G';
    $B9FE..$BBF6 : result := 'H';
    $BBF7..$BFA5 : result := 'J';
    $BFA6..$C0AB : result := 'K';
    $C0AC..$C2E7 : result := 'L';
    $C2E8..$C4C2 : result := 'M';
    $C4C3..$C5B5 : result := 'N';
    $C5B6..$C5BD : result := 'O';
    $C5BE..$C6D9 : result := 'P';
    $C6DA..$C8BA : result := 'Q';
    $C8BB..$C8F5 : result := 'R';
    $C8F6..$CBF9 : result := 'S';
    $CBFA..$CDD9 : result := 'T';
    $CDDA..$CEF3 : result := 'W';
    $CEF4..$D188 : result := 'X';
    $D1B9..$D4D0 : result := 'Y';
    $D4D1..$D7F9 : result := 'Z';
  else
    result := char(0);
  end;
end;
//______________________________________________________________________________
{-------------------------}
{  得到桌面列表试图的句柄 }
{-------------------------}
function TFun.GetDesktopListViewHandle: THandle;
var
  S: String;
begin
  Result := FindWindow('ProgMan', nil);
  Result := GetWindow(Result, GW_CHILD);
  Result := GetWindow(Result, GW_CHILD);
  SetLength(S, 40);
  GetClassName(Result, PChar(S), 39);
  if PChar(S) <> 'SysListView32' then Result := 0;
end;
//______________________________________________________________________________

{----------------TIconHintX------------------}
{    重载ActivateHint，调整输出字符长度      }
{--------------------------------------------}
procedure TIconHintX.ActivateHint(Rect: TRect; const AHint: string);
type
  TAnimationStyle = (atSlideNeg, atSlidePos, atBlend);
const
  AnimationStyle: array[TAnimationStyle] of Integer = (AW_VER_NEGATIVE,
    AW_VER_POSITIVE, AW_BLEND);
var
  Animate: BOOL;
  Style: TAnimationStyle;
  pos:Tpoint;
begin
  GetCursorPos(Pos);
  FActivating := True;
  try
    Caption :='  '+AHint; (*前面价2个空格让图标可以正常显示*)
    Inc(Rect.right,12);
    Inc(Rect.Bottom,4);
    UpdateBoundsRect(Rect);
    if Rect.Top + Height > Screen.DesktopHeight then
      Rect.Top := Screen.DesktopHeight - Height;
    if Rect.Left + Width > Screen.DesktopWidth then
      Rect.Left := Screen.DesktopWidth - Width;
    if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;
    if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;
    SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,SWP_NOACTIVATE);
    if (GetTickCount - FLastActive > 250) and (Length(AHint) < 100) and
       Assigned(AnimateWindowProc) then
    begin
      SystemParametersInfo(SPI_GETTOOLTIPANIMATION, 0, @Animate, 0);
      if Animate then
      begin
        SystemParametersInfo(SPI_GETTOOLTIPFADE, 0, @Animate, 0);
        if Animate then
          Style := atBlend
        else
          if Pos.Y > Rect.Top then
            Style := atSlideNeg
          else
            Style := atSlidePos;
        AnimateWindowProc(Handle, 100, AnimationStyle[Style] or AW_SLIDE);
      end;
    end;
    ParentWindow := Application.Handle;
    ShowWindow(Handle, SW_SHOWNOACTIVATE);
    Invalidate;
  finally
    FLastActive := GetTickCount;
    FActivating := False;
  end;
end;
//______________________________________________________________________________
{function TIconHintX.CalcHintRect(MaxWidth: Integer; const AHint: string;
  AData: Pointer): TRect;
var
  Hicon:TBitmap;
begin
  Hicon:=TBitmap.Create;
  Hicon.LoadFromResourceName(Hinstance,'HICON');
 //-----
  Result := inherited CalcHintRect(MaxWidth,AHint, AData);
  Result.Right := (Length(AHint) * 5) + Hicon.Width*4;
  Result.Bottom := (Hicon.Height)+4;
  Hicon.Free;
end;    }
//______________________________________________________________________________

procedure TIconHintX.Paint;
var
  Hicon:TBitmap;
  R: TRect;
begin
  inherited;
  R := ClientRect;
  Inc(R.Left, 20);
  Inc(R.Top, 2);
  //-------
  Hicon:=TBitmap.Create;
  Hicon.LoadFromResourceName(Hinstance,'HICON');
  color:=$00EEFDF2;
  Canvas.Draw(1,1,Hicon);
  SendMessage(Handle, WM_NCPAINT, 0, 0); //画提示栏边框
  Hicon.Free;
end;
//______________________________________________________________________________

{-------------------------------}
{     设置parent窗体的字体      }
{-------------------------------}
procedure TFun.SetParentWinDefFont(Sender:TObject;const defFont: Tfont);
begin
   if defFont=nil then
   begin;
     {设置默认}
     TForm(Sender as TComponent).Font.Name:='宋体';
     TForm(Sender as TComponent).Font.Size:=9;
     TForm(Sender as TComponent).Font.Height:=-12;
     TForm(Sender as TComponent).Font.Color:=clblack;
     TForm(Sender as TComponent).Font.Charset:=GB2312_CHARSET
   end else
     (*用户定义*)
     TForm(Sender as TComponent).Font:=defFont
end;
//______________________________________________________________________________

{---------------------------}
{      计算x的Y次方         }
{---------------------------}
function TFun.Squ(X, Y: integer): integer;
var
  i,sum:integer;
begin
  sum:=1;
  for i:=1 to Y do  sum:=sum*X;
  result:=sum
end;
{浮点型}
function TFun.Squ(X: Double; Y: integer): Double;
var
  i:integer;
  dsum:double;
begin
  dsum:=1;