vgsystem.pas

大家是不是为不知道如何在VB学到绝地程序

  FBuff := @ABuff;
  FBuffSize := ACount;
  FData := AData;
end;

{ TBlockCompressor }
procedure TBlockCompressor.GetBlock(var Buffer; Count: Integer; var ActualCount: Integer);
begin
  ActualCount := Min(Count, BuffSize - SourcePos);
  Move(Pointer(Integer(Buff) + SourcePos)^, Buffer, ActualCount);
  FSourcePos := FSourcePos + ActualCount;
end;

procedure TBlockCompressor.PutBlock(var Buffer; Count: Integer; var ActualCount: Integer);
begin
  ActualCount := Stream.Write(Buffer, Count);
end;

{ TCompressorList}
destructor TCompressorList.Destroy;
begin
  ListClear(FItems);
  inherited;
end;

function TCompressorList.GetCompressor(Index: Integer): TCompressorClass;
begin
  Result := ListItem(FItems, Index);
end;

function TCompressorList.GetCount: Integer;
begin
  Result := ListCount(FItems);
end;

function TCompressorList.CreateCompressor(Sign: TSignature): TCompressor;
var
  C: TCompressorClass;
begin
  C := FindCompressor(Sign);
  if not Assigned(C) then
    raise EInvalidOp.Create(Format(LoadStr(SUknownCompressorSign), [Sign]));
  Result := C.Create;
end;

function TCompressorList.FindCompressor(Sign: TSignature): TCompressorClass;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
  begin
    Result := Compressors[I];
    if Result.Sign = Sign then Exit;
  end;
  Result := nil;
end;

procedure TCompressorList.RegisterCompressor(CompressorClass: TCompressorClass);
begin
  if FindCompressor(CompressorClass.Sign) = nil then
    ListAdd(FItems, CompressorClass);
end;

procedure TCompressorList.UnRegisterCompressor(CompressorClass: TCompressorClass);
begin
  ListRemove(FItems, CompressorClass);
end;

{ TReadMemoryStream }
procedure TReadMemoryStream.SetPointer(Ptr: Pointer; Size: Longint);
begin
  inherited SetPointer(Ptr, Size);
end;

function TReadMemoryStream.Write(const Buffer; Count: Longint): Longint;
asm
        XOR     EAX,EAX
end;

{ TWinFileStream }
constructor TWinFileStream.Create(const FileName: TFileName; Access: TFileAccessMode;
  Share: TFileShareMode; Creation: TFileCreationMode; FileAttrsAndFlags: DWord;
  lpSecurity: PSecurityAttributes; TemplateHandle: Integer);
var
  AHandle: Integer;
begin
  AHandle := CreateFile(PChar(FileName), Byte(Access) and 3 shl 30,
    Byte(Share), lpSecurity, CreationMode[Creation],
    FileAttrsAndFlags, TemplateHandle);

  if AHandle < 0 then
  begin
    if Creation in [fcmCreateNew, fcmCreateAlways] then
      raise EFCreateError.CreateFmt(ResStr(SFCreateError), [FileName]) else
      raise EFOpenError.CreateFmt(ResStr(SFOpenError), [FileName]);
  end;
  inherited Create(AHandle);
end;

destructor TWinFileStream.Destroy;
begin
  if Handle >= 0 then FileClose(Handle);
  inherited;
end;

{ TClassItem }
constructor TClassItem.Create(AClassType: TClass; AData: Pointer; AInfo: string);
begin
  FClassType := AClassType;
  FData := AData;
  FInfo := AInfo;
end;

{ TClassList }
destructor TClassList.Destroy;
begin
  Clear;
  inherited;
end;

procedure TClassList.Clear;
begin
  ListDestroy(FItems);
end;

function TClassList.ClassItemByName(const AClassName: TClassName): TClassItem;
begin
  Result := FindClassItem(AClassName);
  if not Assigned(Result) then
    raise EClassNotFound.Create({$IFNDEF _D3_}FmtLoadStr(SClassNotFound, [AClassName]){$ELSE}Format(SClassNotFound, [AClassName]){$ENDIF});
end;

function TClassList.FindClassItem(const AClassName: TClassName): TClassItem;
var
  I: Integer;
begin
  I := IndexOf(AClassName);
  if I >= 0 then
    Result := Items[I] else Result := nil;
end;

function TClassList.GetCount: Integer;
begin
  Result := ListCount(FItems);
end;

function TClassList.GetItem(Index: Integer): TClassItem;
begin
  Result := ListItem(FItems, Index);
end;

function TClassList.IndexOf(const AClassName: TClassName): Integer;
var
  AClass: TClass;
begin
  for Result := 0 to Count - 1 do
  begin
    AClass := Items[Result].GetClassType;
    if AnsiCompareText(AClass.ClassName, AClassName) = 0 then Exit;
  end;
  Result := -1;
end;

function TClassList.IndexOfClass(AClass: TClass; Inheritance: Boolean): Integer;
begin
  if Inheritance then
  begin
    for Result := Count - 1 downto 0 do
      if IsClass(AClass, Items[Result].GetClassType) then Exit;
  end else begin
    for Result := 0 to Count - 1 do
      if Items[Result].GetClassType = AClass then Exit;
  end;
  Result := -1;
end;

function TClassList.InternalRegister(AClass: TClass; const AData: Pointer; const AInfo: string; Inheritance: Boolean): TClassItem;
var
  I, J: Integer;
  Item: TClassItem;
begin
  Result := TClassItem.Create(AClass, AData, AInfo);
  try
    if Inheritance then
    begin
      J := 0;
      for I := Count - 1 downto 0 do
      begin
        Item := Items[I];
        if IsClass(AClass, Item.GetClassType) then
        begin
          J := I + 1;
          Break;
        end;
      end;
    end else
      J := Count;
    ListInsert(FItems, J, Result);
  except
    Result.Free;
    raise;
  end;
end;

procedure TClassList.InternalUnRegister(AClass: TClass; Index: Integer);
begin
  ListDelete(FItems, Index);
end;

procedure TClassList.RegisterClass(AClass: TClass; const AData: Pointer; const AInfo: string; Inheritance: Boolean);
begin
  if IndexOfClass(AClass, False) < 0 then
    InternalRegister(AClass, AData, AInfo, Inheritance);
end;

procedure TClassList.UnregisterClass(AClass: TClass);
var
  I: Integer;
begin
  I := IndexOfClass(AClass, False);
  if I >= 0 then InternalUnRegister(AClass, I);
end;

{ TCustomPoolInstance }

{ TCustomPoolManager }
constructor TCustomPoolManager.Create(AMaxCount: Integer; ATimeout: DWord);
begin
  FItems := TvgThreadList.Create;
  FTimeout := ATimeout;
  FMaxCount := AMaxCount;
  FSemaphore := CreateSemaphore(nil, FMaxCount, FMaxCount, nil);
end;

destructor TCustomPoolManager.Destroy;
begin
  FItems.Free;
  CloseHandle(FSemaphore);
  inherited;
end;

procedure TCustomPoolManager.Clear;
var
  I: Integer;
begin
  Lock;
  try
    for I := 0 to FItems.Count - 1 do
      Items[I].Free;
    FItems.Clear;
  finally
    Unlock;
  end;
end;

procedure TCustomPoolManager.ClearUnused;
var
  I: Integer;
  Item: TCustomPoolInstance;
begin
  Lock;
  try
    for I := FItems.Count - 1 downto 0 do
    begin
      Item := Items[I];
      if not Item.InUse then
      begin
        Item.Free;
        FItems.Remove(Item);
      end;
    end;
  finally
    Unlock;
  end;
end;


procedure TCustomPoolManager.Lock;
begin
  FItems.Lock;
end;

procedure TCustomPoolManager.Unlock;
begin
  FItems.Unlock;
end;

function TCustomPoolManager.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TCustomPoolManager.GetItem(Index: Integer): TCustomPoolInstance;
begin
  Result := FItems[Index];
end;

function TCustomPoolManager.LockInstance: TCustomPoolInstance;

  procedure RaiseError;
  begin
  {$IFDEF _D3_}
    raise EOutOfResources.Create(SOutOfResources);
  {$ELSE}
    raise EInvalidOp.Create(LoadStr(SOutOfResources));
  {$ENDIF}
  end;

var
  I: Integer;
  Instance: TCustomPoolInstance;
begin
  Result := nil;
  if WaitForSingleObject(FSemaphore, Timeout) = WAIT_FAILED then
    RaiseError;
  Lock;
  try
    for I := 0 to FItems.Count - 1 do
    begin
      Instance := FItems[I];
      if GetLock(Instance) then
      begin
        Result := Instance;
        Exit;
      end;
    end;
    if FItems.Count < MaxCount then
      Result := CreateNewInstance
    else
      RaiseError;
  finally
    Unlock;
  end;
end;

procedure TCustomPoolManager.UnlockInstance(Instance: TCustomPoolInstance);
begin
  Lock;
  try
    LockedInstance(Instance, False);
    Instance.FInUse := False;
    ReleaseSemaphore(FSemaphore, 1, nil);
  finally
    Unlock;
  end;
end;

procedure TCustomPoolManager.LockedInstance(Instance: TCustomPoolInstance; Value: Boolean);
begin
end;

procedure TCustomPoolManager.CheckLocked(Instance: TCustomPoolInstance; var InUse: Boolean);
begin
end;

function TCustomPoolManager.GetLock(Instance: TCustomPoolInstance): Boolean;
begin
  Lock;
  try
    CheckLocked(Instance, Instance.FInUse);
    Result := not Instance.InUse;
    if Result then
      Instance.FInUse := True;
    LockedInstance(Instance, True);
  finally
    Unlock;
  end;
end;

function TCustomPoolManager.CreateNewInstance: TCustomPoolInstance;
begin
  Lock;
  try
    Result := InternalCreateNewInstance;
    if Assigned(Result) then
    try
      Result.FInUse := True;
      Result.FPoolManager := Self;
      FItems.Add(Result);
      LockedInstance(Result, True);
    except
      Result.Free;
      raise;
    end;
  finally
    Unlock;
  end;
end;

{ TComponentPoolInstance }
destructor TComponentPoolInstance.Destroy;
begin
  FComponent.Free;
  inherited;
end;

{ TComponentPoolManager }
constructor TComponentPoolManager.Create(AComponentClass: TComponentClass;
  AMaxCount: Integer; ATimeout: DWord);
begin
  inherited Create(AMaxCount, ATimeout);
  FComponentClass := AComponentClass;
end;

function TComponentPoolManager.CreateComponent(Instance: TCustomPoolInstance): TComponent;
begin
  Result := FComponentClass.Create(nil);
end;

function TComponentPoolManager.InternalCreateNewInstance: TCustomPoolInstance;
begin
  Result := TComponentPoolInstance.Create;
  try
    TComponentPoolInstance(Result).FComponent := CreateComponent(Result);
  except
    Result.Free;
    raise;
  end;
end;

procedure TComponentPoolManager.CheckLocked(Instance: TCustomPoolInstance;
  var InUse: Boolean);
begin
  if TComponentPoolInstance(Instance).Component = nil then
  begin
    TComponentPoolInstance(Instance).FComponent := CreateComponent(Instance);
    InUse := False;
  end;
end;

{$IFDEF _D3_}
{ TIntfPoolInstance }
function TIntfPoolInstance.GetDispatch: IDispatch;
begin
  FUnk.QueryInterface(IDispatch, Result);
end;

function TIntfPoolInstance.GetVariant: OleVariant;
begin
  Result := AsDispatch;
end;

destructor TIntfPoolInstance.Destroy;
begin
  FUnk := nil;
  inherited;
end;

{ TIntfPoolManager }
function TIntfPoolManager.InternalCreateNewInstance: TCustomPoolInstance;
begin
  Result := TIntfPoolInstance.Create;
  try
    TIntfPoolInstance(Result).AsUnknown := CreateUnknown(Result);
  except
    Result.Free;
    raise;
  end;
end;

function TIntfPoolManager.LockInstance: TIntfPoolInstance;
begin
   Result := TIntfPoolInstance(inherited LockInstance);
end;

{ TEnumeratorObject }
function TEnumeratorObject.CreateEnumerator: TEnumeratorObject;
begin
  Result := nil;
end;

function TEnumeratorObject.Fetch(Index: LongWord; var VarResult: OleVariant): HResult;
begin
  Result := S_FALSE;
end;

function TEnumeratorObject.GetCount: LongWord;
begin
  Result := 0;
end;

{ TEnumeratorObject.IEnumVariant }
{$IFDEF _D5_}
function TEnumeratorObject.Next(celt: LongWord; var rgvar : OleVariant;
  out pceltFetched: LongWord): HResult;
{$ELSE}
function TEnumeratorObject.Next(celt: Longint; out elt;
  pceltFetched: PLongint): HResult; stdcall;
{$ENDIF}
var
{$IFDEF _D5_}
  I: LongWord;
{$ELSE}
  I: Longint;
{$ENDIF}
  Tmp: OleVariant;
begin
  I := 0;
  while (I < celt) and (FFetched < GetCount) and (Fetch(FFetched, Tmp) = S_OK) do
  begin
{$IFDEF _D5_}
    TVariantArray(rgvar)[I] := Tmp;
{$ELSE}
    TVariantArray(elt)[I] := Tmp;
{$ENDIF}
    Inc(FFetched);
    Inc(I);
  end;

  if I = celt then
  begin
{$IFDEF _D5_}
    if Assigned(@pceltFetched) then
      pceltFetched := I;
{$ELSE}
    if Assigned(pceltFetched) then
      pceltFetched^ := I;
{$ENDIF}
    Result := S_OK;
  end else
    Result := S_FALSE;
end;

{$IFDEF _D5_}
function TEnumeratorObject.Skip(celt: LongWord): HResult;
{$ELSE}
function TEnumeratorObject.Skip(celt: Longint): HResult;
{$ENDIF}
begin
{$IFDEF _D5_}
  if FFetched + celt <= GetCount then
{$ELSE}
  if FFetched + LongWord(celt) <= GetCount then
{$ENDIF}
  begin
    Inc(FFetched, celt);
    Result := S_OK;
  end else
    Result := S_FALSE;
end;

function TEnumeratorObject.Reset: HResult;
begin
  FFetched := 0;
  Result := S_OK;
end;

function TEnumeratorObject.Clone(out Enum: IEnumVariant): HResult;
var
  Enumerator: TEnumeratorObject;
begin
  Enumerator := CreateEnumerator;
  if Assigned(Enumerator) then
  begin
    Enumerator.FFetched := FFetched;
    Enum := Enumerator as IEnumVariant;
    Result := S_OK;
  end else
    Result := E_NOTIMPL;
end;
{$ENDIF}

initialization

finalization
   FCompressorList.Free;

end.