常用自定義函式

阿新 • • 發佈：2020-11-05

做網路程式時, 經常用到記憶體之間的相互複製轉換函式.於是寫下了下面一些函式

{-------------------------------------------------------------
  單元:    BaseFunc
  日期:    2003 06 24
  作者:    王寒鬆 Administrator
  說明:    一些基礎操作函式
--------------------------------------------------------------}
Unit BaseFunc;

Interface
Uses windows, messages, sysutils, classes, controls, stdctrls, variants, comobj;

 


Function GetPtrSize(p: Pointer): Integer;

 
//判斷指標是否是一個物件, From Amingoo

Function PtrIsObject2(p: Pointer; AClass: TClass;
  FindDerived: Boolean = True): Boolean;

 

//判斷一個字串是否是一個整數 和 try StrtoInt except 相比， 簡單實用

Function IsInt(Text: String): Boolean;


//記憶體處理
Procedure CopyStrToBuf(Str: String; Buf: Pointer; Position: Integer);
Function CopyBufToStr(buf: Pointer; Len: Integer): String;
Procedure StrToArray(Src: String; Dest: Pointer; OffSet: Integer; Len: Integer);
Procedure MoveEx(Source, Dest: Pointer; SrcOffSet: integer; DestOffSet: integer; Count: Integer);
Procedure _VClearMem(PMem: Pointer; MemSize: Integer);
Function _VGetMem(MemSize: Integer): Pointer;
Procedure _VFreeMem(PMem: Pointer; MemSize: Integer);
Function MemoryStreamToOleVariant(Strm: TMemoryStream): OleVariant;
Function OleVariantToMemoryStream(OV: OleVariant): TMemoryStream;

 


 
//雜專案
//取得路徑資訊
Function _ExtractFilePath(FileName: String): String;
//判斷有無漢字字元
Function HasHZChar(Str: String): Boolean;

//訊息處理
//傳送tab 鍵盤訊息
Procedure PostTabKey(WinControl : TWinControl);

Implementation


Function GetPtrSize(p: Pointer): Integer;
Const
  cThisUsedFlag = 2;
  cPrevFreeFlag = 1;
  cFillerFlag  
= Integer($80000000);
  cFlags = cThisUsedFlag Or cPrevFreeFlag Or cFillerFlag;
Type
  PUsed = ^TUsed;
  TUsed = Packed Record
    sizeFlags: Integer;
  End;
Var
  a: pChar;
Begin
//不驗證p 的有效性, 也不進行臨界區. 如果p 正在釋放, 下面的程式碼可能導致出錯.
//如果是正在分析的記憶體塊, 其長度值還未在PUsed 中填寫. 這種情況下, 返回值未知.
  a := p;
//當前指標的實際記憶體塊首地址
  dec(a, sizeof(TUsed));
//是否是待釋放的記憶體塊
  If (PUsed(a).sizeFlags And cThisUsedFlag) <> 0 Then
  Begin
//取總長度
    Result := PUsed(a).sizeFlags And Not cFlags;
    If (PUsed(a).sizeFlags And cFillerFlag) = 0 Then //取實際長度
      dec(Result, sizeof(TUsed));
  End;
End;


Function PtrIsObject2(p: Pointer; AClass: TClass;
  FindDerived: Boolean = True): Boolean;
Var
  AObject: TObject;
  ClassPtr: Pointer;
Begin
  If GetPtrSize(p) < 4 Then
    Exit;
  AObject := TObject(p);
  ClassPtr := PPointer(p)^;
  Result := (ClassPtr = AClass) Or
    (FindDerived And
    (Integer(ClassPtr) >= 64 * 1024) And
    (PPointer(PChar(ClassPtr) + vmtSelfPtr)^ = Pointer(ClassPtr)) And
    (AObject Is AClass));
End;

 


{-------------------------------------------------------------
  過程:    IsInt    判斷一個字串是否是整數
  日期:2003 09 07
  作者:    王寒鬆 Administrator
  引數:    Text: string  返回值:  是整數的時候返回真  否則為假
--------------------------------------------------------------}

Function IsInt(Text: String): Boolean;
Var
  Code: integer;
  TempNumber: integer;
Begin
  Val(Text, TempNumber, Code);
  Result := Code = 0;
End;

 

{-----------------------------------------------------------------------------
  過程:    CopyStrToBuf    拷貝一個字串的內容到一個buffer中.
  例如buffer : array[0..4095] of char;  buf := @buffer    Position 引數規定從BUFFER的第幾個位元組開始寫STR
  作者:    Wanghs Administrator
  日期:    2003 07 27
  引數:    Str: string; var Buf : Pointer; Position : Integer;
  返回值:  Boolean
-----------------------------------------------------------------------------}

Procedure CopyStrToBuf(Str: String; Buf: Pointer; Position: Integer);
Var PC: PChar;
  p: Pointer;
Begin
  PC := PChar(Str);
  P := Pointer(Integer(Buf) + Position);
  Move(PC^, P^, Length(Str));
End;


{-------------------------------------------------------------
  過程:    CopyBufToStr  拷貝一個BUFFER的內容到一個字串中
  日期:2003 09 07
  作者:    王寒鬆 Administrator
  引數:    buf: Pointer; Len: Integer  返回值:  string
--------------------------------------------------------------}

Function CopyBufToStr(buf: Pointer; Len: Integer): String;
Begin
  SetString(Result, PChar(buf), Len);
End;


{-----------------------------------------------------------------------------
  過程:    StrToArray   字串複製(非賦值)為字串陣列 OffSet 規定從字串中第幾個字串轉換起
  作者:    Wanghs Administrator  日期:    2003 08 12
  引數:    Src: string; Dest: Pointer; OffSet: Integer; Len: Integer  返回值:  None
-----------------------------------------------------------------------------}

Procedure StrToArray(Src: String; Dest: Pointer; OffSet: Integer; Len: Integer);
Var pc: PChar;
  Des: Pointer;
Begin
  pc := PChar(SRC);
  des := Pointer(Integer(Dest) + OffSet);
  system.Move(pc^, Des^, Len);
End;

{-----------------------------------------------------------------------------
  過程:    MoveEx  Move 函式的增強版.  從一個BUF中指定的位置複製指定數量的內容到另一個BUF
  作者:    Wanghs Administrator  日期:    2003 05 07
  引數:    Source , Dest : Pointer ; SrcOffSet : integer; DestOffSet : integer; Count : Integer  返回值:  None
-----------------------------------------------------------------------------}

Procedure MoveEx(Source, Dest: Pointer; SrcOffSet: integer; DestOffSet: integer; Count: Integer);
Var pSrc, pDes: Pointer;
Begin
  pSrc := Pointer(Integer(Source) + SrcOffSet);
  pDes := Pointer(Integer(Dest) + DestOffset);
  system.Move(PSrc^, pDes^, Count);
End;

{ 過程:    _VClearMem 填充一塊記憶體為0   日期:2003 05 07
  作者:    王寒鬆 Administrator
  引數:    PMem: Pointer; MemSize: Integer  返回值:  None }

Procedure _VClearMem(PMem: Pointer; MemSize: Integer);
Begin
  Fillchar(PMem, MemSize, 0);
End;

{ 過程:    _VGetMem   設定一塊虛擬記憶體  日期:2003 05 07
  作者:    王寒鬆 Administrator
  引數:    MemSize: Integer  返回值:  Pointer }

Function _VGetMem(MemSize: Integer): Pointer;
Begin
  Result := VirtualAlloc(0, MemSize, Mem_ReServe Or Mem_Commit, PAGE_READWRITE);
End;

{ 過程:    _VFreeMem  釋放一塊虛擬記憶體  與 _VGetMem對應
  日期:2003 05 07
  作者:    王寒鬆 Administrator
  引數:    PMem: Pointer; MemSize: Integer  返回值:  None }

Procedure _VFreeMem(PMem: Pointer; MemSize: Integer);
Begin
  VirtualFree(PMem, MemSize, Mem_DeCommit Or Mem_Release);
End;

{ 過程:    _ExtractFilePath 取得一個檔案的路徑
  日期:2003 09 07
  作者:    王寒鬆 Administrator
  引數:    FileName: string  返回值:  string }

Function _ExtractFilePath(FileName: String): String;
Begin
  Result := ExtractFilePath(FileName);
  If (Result <> '') And (Result[Length(Result)] <> '\') Then
    Result := Result + '\';
End;


{-------------------------------------------------------------
  過程:    HasHZChar
  日期:    2003 12 18
  作者:    王寒鬆 Administrator
  說明:    判斷一個ANSI字串中是否有漢字字元
--------------------------------------------------------------}

Function HasHZChar(Str: String): Boolean;
Var i: Integer;
Begin
  Result := False;
  For i := 0 To Length(Str) Do
    If ORD(Str[i]) > 127 Then
    Begin
      Result := True;
      Break;
    End;
End;

//記憶體流轉換到OLEVARIANT 型別  wanghs  2003-02-10
Function MemoryStreamToOleVariant(Strm: TMemoryStream): OleVariant;
Var
  Data: PByteArray;
Begin
  Result := VarArrayCreate([0, Strm.Size - 1], varByte);
  Data := VarArrayLock(Result);
  Try
    Strm.Position := 0;
    Strm.ReadBuffer(Data^, Strm.Size);
  Finally
    VarArrayUnlock(Result);
  End;
End;

//OleVariant 型別 複製到記憶體流  wanghs 2003-02-10

Function OleVariantToMemoryStream(OV: OleVariant): TMemoryStream;
Var
  Data: PByteArray;
  Size: integer;
Begin
  Result := TMemoryStream.Create;
  Try
    Size := VarArrayHighBound(OV, 1) - VarArrayLowBound
      (OV, 1) + 1;
    Data := VarArrayLock(OV);
    Try
      Result.Position := 0;
      Result.WriteBuffer(Data^, Size);
    Finally
      VarArrayUnlock(OV);
    End;
  Except
    Result.Free;
    Result := Nil;
  End;
End;

 

//對於處於 TFRAME 中的控制元件， 在處理 回車鍵 -> TAB鍵時， 下面的函式要比

// keybdEvent(vk_tab, 0,0,0 ) 和 selectNext , Perform  等 要好用些


Procedure PostTabKey(WinControl : TWinControl);
Begin
  if Not Assigned(WinControl.Owner) then Exit; 
  PostMessage( TWinControl(WinControl.Owner).Handle, WM_KeyDown, VK_Tab, 0);
  PostMessage( TWinControl(WinControl.Owner).Handle, WM_KeyUP, VK_Tab, 0);
End;