常用自定义函数

做网络程序时, 经常用到内存之间的相互复制转换函数.于是写下了下面一些函数

{-------------------------------------------------------------
  单元:    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;