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

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

上一页12 3 下一页