pubfuns.pas

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

unit PubFuns;

interface

uses
  Classes, SysUtils, Variants, StrUtils, Controls, Forms, Windows, ShellAPI,
  Registry, DBISAMTb, Zlib, RxRichEd, DBRichEd, Graphics;

type
  TExecState = (esNormal, esMinimized, esMaximized, esHidden);
Type
  IPMacByte=array[1..6] of byte;
var
  pvTmpCalcTime : DWORD;
  { Other Functions }

  function pGetCurDir : String;
  function pGetTempDir : String;
  function pStrToInt(AString : String) : Integer;
  function pIIF(IsTrue : Boolean;TrueValue ,FalseValue : Variant) : Variant;
  function pVarToStr(VarStr : Variant) : String;
  function pFocusControl(AControl : TWinControl) : Boolean;
  function pStartWait : Boolean;
  function pStopWait : Boolean;
  function pStartCalcTime : Boolean;
  function pStopCalcTime : DWORD;
  function pSaveRegister(ShortKey, VarName, Value : String) : Boolean;
  function pLoadRegister(ShortKey, VarName : String) : String;
  function pFileExecuteWait(const FileName, Params, StartDir: string;
  InitialState: TExecState): Integer;
  function pGetLastPathName(aPathName : String) : String;
  function pShowForm(AFormClass : TFormClass;Var Aform:Tform) : DWORD;

  { DataBase Functions }
  
  { Zlib Functions }
  function pCompress(InStream, OutStream: TMemoryStream) : Boolean;
  function pDeCompress(var InStream, OutStream: TMemoryStream) : Boolean;

  { Insert Picture }
  function ConvertBitmapToRTF(const Bitmap: TBitmap): string;
  procedure InsertBitmapIntoRxRichEdit(const Bitmap: TBitmap; const RxRichEdit:
  TRxRichEdit); overload;
  procedure InsertBitmapIntoRxRichEdit(const GraphicFileName: string; const
  RxRichEdit: TRxRichEdit); overload;
  Function PFindWindow(const Classname:String):Integer;
  Function deleteBBK(Dir:String;CanDel:bool):boolean;
  Function MoveBBK(Dir:string;CanDel:bool):boolean;
  {Str Function}
  Function StrIPMacToByte(Const IPAddr:String;var OkFlag:boolean):IPMacByte;
  Function StrToIntRange(const S: string; Min, Max: Longint): Longint;
  Function DWordToboolStr(Const Aword:Dword):String;
  Function WordToboolStr(Const Aword:word):String;
  Function ByteToboolStr(Const AByte:Byte):String;
implementation

function pGetCurDir : String;
begin
  Result := ExtractFilePath(ParamStr(0));
  if RightStr(Result,1) <> '\' then
     Result := Result + '\';
end;

function pGetTempDir : String;
var
  Buff : pChar;
begin
  Buff := GetMemory(100);
  GetTempPath(99,Buff);
  Result := String(Buff);
  if RightStr(Result,1) <> '\' then Result := Result + '\';
end;

function pStrToInt(AString : String) : Integer;
begin
  if Trim(AString) <> '' then
  begin
    try
      Result := StrToInt(AString);
    except
      Result := 0;
    end;
  end else
  begin
    Result := 0;
  end;
end;

function pIIF(IsTrue : Boolean;TrueValue ,FalseValue : Variant) : Variant;
begin
  if IsTrue
     then Result := TrueValue
     else Result := FalseValue;
end;

function pVarToStr(VarStr : Variant) : String;
begin
  if VarIsNull(VarStr)
     then Result := ''
     else Result := VarStr;
end;

function pFocusControl(AControl : TWinControl) : Boolean;
begin
  Result := True;
  if AControl.CanFocus then
  begin
    try
      AControl.SetFocus;
    except
      Result := False;
    end;
  end;
end;

function pStartWait : Boolean;
begin
  Screen.Cursor := crHourGlass;
  Result := True;
end;

function pStopWait : Boolean;
begin
  Screen.Cursor := crDefault;
  Result := True;
end;

function pStartCalcTime : Boolean;
begin
  pvTmpCalcTime := GetTickCount;
  Result := True;  
end;

function pStopCalcTime : DWORD;
begin
  Result := GetTickCount - pvTmpCalcTime;
end;

function pSaveRegister(ShortKey, VarName, Value : String) : Boolean;
var
  Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  if Reg.OpenKey('SoftWare\NicetySoft\WinYZCX\'+ShortKey,True) then
  begin
    Reg.WriteString(VarName,Value);
  end;
  Reg.Free;
  Result := True;
end;

function pLoadRegister(ShortKey, VarName : String) : String;
var
  Reg : TRegistry;
begin
  Result := '';
  Reg := TRegistry.Create;
  if Reg.OpenKey('SoftWare\NicetySoft\WinYZCX\'+ShortKey,False) then
  begin
    Result := Reg.ReadString(VarName);
  end;
  Reg.Free;
end;

function pFileExecuteWait(const FileName, Params, StartDir: string;
  InitialState: TExecState): Integer;
var
  Info: TShellExecuteInfo;
begin
  FillChar(Info, SizeOf(Info), 0);
  Info.cbSize := SizeOf(TShellExecuteInfo);
  with Info do begin
    fMask := SEE_MASK_NOCLOSEPROCESS;
    Wnd := Application.Handle;
    lpFile := PChar(FileName);
    lpParameters := PChar(Params);
    lpDirectory := PChar(StartDir);
    nShow := SW_SHOWNORMAL;
  end;
  ShellExecuteEx(@Info);//取消等候
 // if ShellExecuteEx(@Info) then begin
  //  repeat
  //    Application.ProcessMessages;
  //    GetExitCodeProcess(Info.hProcess, ExitCode);
  //  until (ExitCode <> STILL_ACTIVE) or Application.Terminated;
  //  Result := ExitCode;
 // end
 // else Result := -1;
end;

function pGetLastPathName(aPathName : String) : String;
begin
  if RightBStr(aPathName,1) = '\' then
     aPathName := LeftBStr(aPathName,Length(aPathName)-1);
  while Pos('\',aPathname) <> 0 do
  begin
    aPathName := MidBStr(aPathName,Pos('\',aPathName)+1,255);
  end;
  Result := aPathName;
end;

function pShowForm(AFormClass : TFormClass;Var Aform:Tform) : Dword;

begin
Try
  AForm := AFormClass.Create(Screen.ActiveForm);
  Result := AForm.ShowModal;
Finally
  AForm.Free;
end;
end; 

function pCompress(InStream, OutStream: TMemoryStream) : Boolean;
var
  lSize : Int64;
  lTempStream : TMemoryStream;
  lCompStream : TCompressionStream;
begin
  lSize := InStream.Size;
  InStream.Position := 0;
  lTempStream := TMemoryStream.Create;
  lCompStream := TCompressionStream.Create(clMax,lTempStream);
  lCompStream.CopyFrom(InStream,0);
  lCompStream.Free;

  OutStream.Clear;
  OutStream.Write(lSize,Sizeof(lSize));
  OutStream.Write(lTempStream.Memory^,lTempStream.Size);
  OutStream.Position := 0;
  lTempStream.Free;
  Result := True;
end;

function pDeCompress(var InStream, OutStream: TMemoryStream) : Boolean;
var
  lSize : Int64;
  lTempStream : TMemoryStream;
  lCompStream : TDecompressionStream;
  lBuffer : pChar;
begin
  InStream.Position := 0;
  InStream.ReadBuffer(lSize, SizeOf(lSize));
  GetMem(lBuffer,lSize);
  lTempStream := TMemoryStream.Create;
  lCompStream := TDecompressionStream.Create(InStream);
  try
    lCompStream.ReadBuffer(lBuffer^, lSize);
    lTempStream.WriteBuffer(lBuffer^, lSize);
    lTempStream.Position := 0;
    OutStream.CopyFrom(lTempStream,lSize);
    OutStream.Position := 0;
  finally
    FreeMem(lBuffer);
    lTempStream.Free;
    lCompStream.Free;
  end;
  Result := True;
end;

function ConvertBitmapToRTF(const Bitmap: TBitmap): string;
var
  bi, bb: string;
  bis, bbs: Cardinal;
  achar: string[2];
  Buffer: string;
  I: Integer;
type
  PWord = ^Word;
begin
  GetDIBSizes(Bitmap.Handle, bis, bbs);
  SetLength(bi, bis);
  SetLength(bb, bbs);
  GetDIB(Bitmap.Handle, Bitmap.Palette, PChar(bi)^, PChar(bb)^);
  SetLength(Buffer, (Length(bb) + Length(bi)) * 2);
  i := 1;
  for bis := 1 to Length(bi) do
  begin
    achar := IntToHex(Integer(bi[bis]), 2);
    PWord(@Buffer[i])^ := PWord(@achar[1])^;
    inc(i, 2);
  end;
  for bbs := 1 to Length(bb) do
  begin
    achar := IntToHex(Integer(bb[bbs]), 2);
    PWord(@Buffer[i])^ := PWord(@achar[1])^;
    inc(i, 2);
  end;
  Result := '{\rtf1 {\pict\dibitmap ' + Buffer + ' }}';
end;

procedure InsertBitmapIntoRxRichEdit(const Bitmap: TBitmap; const RxRichEdit:
  TRxRichEdit); overload;
begin
  RxRichEdit.SelText := ConvertBitmapToRTF(Bitmap);
  RxRichEdit.Paragraph.Alignment := paCenter;
  RxRichEdit.SelLength := 0;
  RxRichEdit.SelStart := RxRichEdit.SelStart + 1;
end;

procedure InsertBitmapIntoRxRichEdit(const GraphicFileName: string; const
  RxRichEdit: TRxRichEdit); overload;
var
  Bitmap: TBitmap;

  Graphic: TPicture;
begin
  Graphic := TPicture.Create;
  try
    Graphic.LoadFromFile(GraphicFileName);

    if Graphic.Graphic is TBitmap then
      Bitmap := Graphic.Bitmap
    else
    begin
      Bitmap := TBitmap.Create;
      Bitmap.Assign(Graphic.Graphic);
    end;

    InsertBitmapIntoRxRichEdit(Bitmap, RxRichEdit);
  finally
    if Bitmap <> Graphic.Bitmap then
      FreeAndNil(Bitmap);

    FreeAndNil(Graphic);
  end;
end;
Function PFindWindow(const Classname:String):Integer;
begin
  Result:=findwindow(PChar(Classname),nil);{查找是否有此类的窗体}
  if Result<>0 then {不为0则程序已运行}
    begin
      messagebox(0,'该程序已经有一个在运行中!','运行',0);{提示程序已运行}
      halt; {退出程序}
    end;
end;


Function deleteBBK(Dir:string;CanDel:bool):boolean;
var
  OPS: TSHFileOpStruct;
  FromBuf: Array[0..128]of Char;
begin
    FillChar(FromBuf, SizeOf(FromBuf), 0); //初始化数组FromBuf
    StrPCopy(FromBuf, Dir +'\BBK\*.*'); //将FromBuf填入源目录
   if CanDel then
       begin
          Result:=true;
          with OPS do
            begin
               pTO:=nil;
               pFrom:=FromBuf;
               wFunc :=FO_DELETE ;
               Wnd := Application.Handle;
               lpszProgressTitle := '正在删除';;
               hNameMappings:= nil;
               fAnyOperationsAborted:= False;
               fFlags :=FOF_NOCONFIRMATION
                                 OR FOF_MULTIDESTFILES
                                 OR FOF_ALLOWUNDO;  // 
            end;
       if ShFileOperation(OPS)<>0 then
            Result:=false
            else
            Result:=true;
       end;
end;

Function MoveBBK(Dir:string;CanDel:bool):boolean;
var
  OPS: TSHFileOpStructA;
  FromBuf,ToBuf: Array[0..128]of Char;
begin
    FillChar(FromBuf, SizeOf(FromBuf), 0); //初始化数组FromBuf
    FillChar(ToBuf, SizeOf(ToBuf), 0); //初始化数组ToBuf
    StrPCopy(ToBuf, Dir +'\BBK'); //将FromBuf填入源目录
    StrPCopy(FromBuf, Dir +'\*.bbk'); //将ToBuf填入目的目录
   if CanDel then
       begin
          Result:=true;
          with OPS do
            begin
               pTO:=ToBuf;
               pFrom:=FromBuf;
               wFunc :=FO_MOVE ;
               Wnd := Application.Handle;
               lpszProgressTitle := 'nil';
               hNameMappings:= nil;
               fAnyOperationsAborted:= False;
               fFlags :=FOF_NOCONFIRMATION
                                 OR FOF_MULTIDESTFILES
            end;
       if ShFileOperationA(OPS)<>0 then
            Result:=false
            else
            Result:=true;
   end;
end;
Function StrIPMacToByte(Const IPAddr:String;var OkFlag:boolean):IPmacByte;
var
   i,j:integer;
   Str:String;
begin
   for i:=1 to 6  do
       Result[i]:=0;
   Str:='';
   j:=0;
   OkFlag:=true;
   for i:=1 to 15 do begin
     if IPAddr[i]<>'.' then begin
        Str:=Str+IPAddr[i];
        Continue;
        end
        else
        begin
          j:=j+1;
          Result[j]:=Byte(StrToInt(trim(Str)));
          Str:='';
        end;
   end;
   Result[4]:=Byte(StrToInt(trim(Str))); 
   if j<>3 then
       OkFlag:=false;
end;
function StrToIntRange(const S: string; Min, Max: Longint): Longint;
begin
  Result := StrToIntdef(S,-1);  // StrToInt is declared in SysUtils
 if (Result=-1) or (Result<Min) or (Result>Max)  then
       Result := 0;
end;
Function ByteToboolStr(Const AByte:Byte):String;
  var
    i:integer;
    W:byte;
    OutBool:String;
begin
    Result:='';
     for i := 8 DOWNTO 1 do begin
        w:=(aByte shr (i-1)) and $0001;
        if w=0 then
          Outbool:='0'
          else
          Outbool:='1';
        Result:=Result+Outbool;
     end; 
end;
Function WordToboolStr(Const Aword:Word):String;
  var
    i:integer;
    W:word;
    OutBool:String;
begin
    Result:='';
     for i := 16 DOWNto 1 do begin
        w:=(Aword shr (i-1)) and $0001;
        if w=0 then
          Outbool:='0'
          else
          Outbool:='1';
        Result:=Result+Outbool;
     end;
end;
Function DWordToboolStr(Const Aword:Dword):String;
  var
    i:integer;
    DW:Dword;
    OutBool:String;
begin
    Result:='';
     for i := 32 DOWNto 1 do begin
        Dw:=(Aword shr (i-1)) and $0001;
        if Dw=0 then
          Outbool:='0'
          else
          Outbool:='1';
        Result:=Result+Outbool;
     end;
end;

end.