tscommon.pas

企业进销存管理系统

    if FDc = 0 then
    begin
        FDc := CreateCompatibleDc(Dc);
        Bmp := CreateCompatibleBitmap(Dc, Width, Height);
        SelectObject(FDc, Bmp);
        FWidth := Width;
        FHeight := Height;
    end
    else if (FWidth < Width) or (FHeight < Height) then
        Resize(Dc, Width, Height);

    Inc(FCount);
end;

procedure TtsMemoryCanvas.FreeDc;
var
    Bmp : HBITMAP;
begin
    if Dc <> 0 then
    begin
        Bmp := GetCurrentObject(Dc, OBJ_BITMAP);

        //delete DC before Bmp to prevent resource leak
        DeleteDC(Dc);
        DeleteObject(Bmp);

        Dc := 0;
        Width := 0;
        Height := 0;
    end;
end;

procedure TtsMemoryCanvas.Release;
begin
    Dec(FCount);
    if (FCount = 0) then FreeDc;
end;

procedure TtsMemoryCanvas.SetObjects(var Rect : TRect);
var
    ClipRegion : HRGN;
begin
    ClipRegion := CreateRectRgn(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    SelectClipRgn(Dc, ClipRegion);
    DeleteObject(ClipRegion);
end;

procedure TtsMemoryCanvas.Lock(AObject: TObject);
begin
    WaitForSingleObject(Mutex, INFINITE);
    FLockingThreadId := GetCurrentThreadId;
    FLockingObject := AObject;
end;

procedure TtsMemoryCanvas.Unlock;
begin
    FLockingThreadId := 0;
    FLockingObject := nil;
    ReleaseMutex(Mutex);
end;

function TtsMemoryCanvas.GetMutex: THandle;
begin
    if FMutex = 0 then
        FMutex := CreateMutex(nil, False, nil);
    Result := FMutex;
end;

function TtsMemoryCanvas.Locked(AObject: TObject): Boolean;
begin
    Result := (FLockingObject <> AObject) and
              (FLockingThreadId = GetCurrentThreadId);

end;

{TtsBitmapElement}

constructor TtsBitmapElement.Create(Bitmap: TBitmap);
begin
    FBitmap := Bitmap;
    FCount := 0;
    FBitmapID := 0;
    FCanFree := False;
end;

destructor TtsBitmapElement.Destroy;
begin
    if FCanFree then FBitmap.Free;
    inherited;
end;

function TtsBitmapElement.Compare(NodeSet: TtsCustomSet; Value : TtsSetElement) : TtsSetOrder;
begin
    Result := CompareKey(NodeSet, [TtsBitmapElement(Value).Bitmap]);
end;

function TtsBitmapElement.CompareKey(NodeSet: TtsCustomSet; const KeyValue : array of const) : TtsSetOrder;
begin
    if Longint(KeyValue[0].VObject) > Longint(Bitmap) then
        Result := ordLarger
    else if Longint(KeyValue[0].VObject) < Longint(Bitmap) then
        Result := ordSmaller
    else
        Result := ordEqual;
end;

{TtsBitmapSet}

procedure TtsBitmapSet.AddElement(Element: TtsBitmapElement);
begin
    Add(Element);
end;

function TtsBitmapSet.GetBitmap(Bitmap: TBitmap): TtsBitmapElement;
begin
    Result := TtsBitmapElement(Get([Bitmap]));
end;

function TtsBitmapSet.AddBitmap(Bitmap: TBitmap): TtsBitmapElement;
var
    Element: TtsBitmapElement;
begin
    Element := GetBitmap(Bitmap);
    if not Assigned(Element) then
    begin
        Element := TtsBitmapElement.Create(Bitmap);
        AddElement(Element);
    end;
    Result := Element;
end;

procedure TtsBitmapSet.RemoveBitmap(Bitmap: TBitmap);
var
    Element: TtsBitmapElement;
begin
    Element := GetBitmap(Bitmap);
    if Assigned(Element) then
    begin
        Dec(Element.FCount);
        if Element.FCount <= 0 then
            Remove([Element.Bitmap]);
    end;
end;

{Tts2DStorage}

constructor Tts2DStorage.Create(Cols, Rows: Integer);
begin
    inherited Create;

    FColsAllocSize := Cols;
    FRowsAllocSize := Rows;

    FData := nil;
    FDataType := nil;
    FColsInRow := nil;
    FColsAllocInRow := nil;
    FRowsInData := 0;
    FInDesignMode := False;
end;

destructor Tts2DStorage.Destroy;
begin
    Clear(0, True);
    inherited Destroy;
end;

function Tts2DStorage.MaxRowSet: Integer;
var
    I: Integer;
begin
    Result := 0;
    for I := FRowsInData - 1 downto 1 do
    begin
        if FData[I] <> nil then
        begin
            Result := I;
            Break;
        end;
    end;
end;

procedure Tts2DStorage.Assign(Source: Tts2DStorage);
var
    Col, Row: Integer;
    NewSize, MaxCol, MaxRow: Integer;
begin
    if not Assigned(Source) then Exit;

    FInDesignMode := Source.FInDesignMode;
    MaxRow := Source.MaxRowSet;
    if MaxRow = 0 then
        Clear(0, True)
    else
    begin
        Clear(MaxRow + 1, False);
        NewSize := CalcMax(RowsAllocSize + 1, MaxRow + 1);
        ResizeRows(NewSize);
    end;

    for Row := 1 to MaxRow do
    begin
        MaxCol := Source.MaxColValueSet(Row);
        if MaxCol = 0
            then ClearRow(Row, 0)
            else ClearRow(Row, CalcMax(MaxCol, ColsAllocSize));

        for Col := MaxCol downto 1 do
            SetValue(Col, Row, Source.GetValue(Col, Row), Source.GetValueType(Col, Row));
    end;
end;

procedure Tts2DStorage.ClearValue(DataCol, DataRow: Integer);
begin
    if FDataType[DataRow][DataCol - 1] in [vtpString, vtpPictureName] then
    begin
        if FData[DataRow][DataCol - 1] <> nil then
            string(FData[DataRow][DataCol - 1]) := ''
    end
    else if FDataType[DataRow][DataCol - 1] = vtpPicture then
    begin
        if FData[DataRow][DataCol - 1] <> nil then
        begin
            CheckInternalBitmap(TBitmap(FData[DataRow][DataCol - 1]), True);
            FData[DataRow][DataCol - 1] := nil;
        end;
    end
    else
        FData[DataRow][DataCol - 1] := nil;

    FDataType[DataRow][DataCol - 1] := vtpNone;
end;

procedure Tts2DStorage.ClearRow(DataRow: Integer; ColsInRow: Integer);
var
    DataCol: Integer;
begin
    if not Assigned(FData) then Exit;
    if FData[DataRow] = nil then Exit;

    for DataCol := 1 to FColsInRow[DataRow] do
        ClearValue(DataCol, DataRow);

    if ColsInRow >= 0 then
        ResizeRowCols(DataRow, ColsInRow);
end;

procedure Tts2DStorage.ClearCol(DataCol: Integer);
var
    DataRow: Integer;
begin
    if not Assigned(FData) then Exit;

    for DataRow := 1 to FRowsInData - 1 do
    begin
        if (DataCol >= 1) and (DataCol <= FColsInRow[DataRow]) then
            ClearValue(DataCol, DataRow);
    end;
end;

procedure Tts2DStorage.Clear(StartRow: Integer; Resize: Boolean);
var
    I: Integer;
begin
    if StartRow = 1 then StartRow := 0;
    for I := StartRow to FRowsInData - 1 do ClearRow(I, 0);

    if Resize then
    begin
        if StartRow = 0 then ResizeRows(StartRow)
                        else ResizeRows(StartRow + 1);
    end;
end;

function Tts2DStorage.GetValue(DataCol, DataRow: Integer): Variant;
begin
    if DataRow > FRowsInData - 1 then
        result := Unassigned
    else if DataCol > FColsInRow[DataRow] then
        result := Unassigned
    else if FDataType[DataRow][DataCol - 1] in [vtpString, vtpPictureName] then
    begin
        if FData[DataRow][DataCol - 1] = nil then
            result := ''
        else
            result := string(FData[DataRow][DataCol - 1])
    end
    else if FDataType[DataRow][DataCol - 1] = vtpInteger then
        result := Integer(FData[DataRow][DataCol - 1])
    else if FDataType[DataRow][DataCol - 1] = vtpPicture then
        result := Integer(FData[DataRow][DataCol - 1])
    else if FDataType[DataRow][DataCol - 1] = vtpNull then
        result := Null
    else
        result := Unassigned;
end;

function Tts2DStorage.GetValueType(DataCol, DataRow: Integer): TtsValueType;
begin
    if DataRow > FRowsInData - 1 then
        result := vtpNone
    else if DataCol > FColsInRow[DataRow] then
        result := vtpNone
    else
        result := FDataType[DataRow][DataCol - 1];
end;

procedure Tts2DStorage.SetBitmapValue(DataCol, DataRow: Longint; CurValueType: TtsValueType; Bitmap: TBitmap);
begin
    if (CurValueType = vtpPicture) then
    begin
        if (FData[DataRow][DataCol - 1] = Pointer(Bitmap)) then Exit;
        ClearValue(DataCol, DataRow);
    end;

    FData[DataRow][DataCol - 1] := Pointer(Bitmap);
    CheckInternalBitmap(Bitmap, False);
end;

procedure Tts2DStorage.CheckCreateRow(DataRow: Integer);
var
    AllocRows: Integer;
begin
    if DataRow > FRowsInData - 1 then
    begin
        if DataRow < FRowsAllocSize + 1 then
            AllocRows := FRowsAllocSize + 1
        else
            AllocRows := DataRow + 10;
        ResizeRows(AllocRows);
    end;
end;

procedure Tts2DStorage.ResizeRows(NewSize: Integer);
begin
    if NewSize > FRowsInData then
    begin
        ReAllocMem(FData, NewSize * SizeOf(PtsRowData));
        ZeroMemory(@FData[FRowsInData], (NewSize - FRowsInData) * SizeOf(PtsRowData));

        ReAllocMem(FDataType, NewSize * SizeOf(PtsRowDataType));
        ZeroMemory(@FDataType[FRowsInData], (NewSize - FRowsInData) * SizeOf(PtsRowDataType));

        ReAllocMem(FColsInRow, NewSize * SizeOf(Integer));
        ZeroMemory(@FColsInRow[FRowsInData], (NewSize - FRowsInData) * SizeOf(Integer));

        ReAllocMem(FColsAllocInRow, NewSize * SizeOf(Integer));
        ZeroMemory(@FColsAllocInRow[FRowsInData], (NewSize - FRowsInData) * SizeOf(Integer));

        FRowsInData := NewSize;
    end
    else if NewSize < FRowsInData then
    begin
        ReAllocMem(FData, NewSize * SizeOf(PtsRowData));
        ReAllocMem(FDataType, NewSize * SizeOf(PtsRowDataType));
        ReAllocMem(FColsInRow, NewSize * SizeOf(Integer));
        ReAllocMem(FColsAllocInRow, NewSize * SizeOf(Integer));
        FRowsInData := NewSize;
    end;
end;

procedure Tts2DStorage.ResizeRowCols(DataRow: Integer; NewSize: Integer);
begin
    if NewSize > FColsAllocInRow[DataRow] then
    begin
        ReAllocMem(FData[DataRow], NewSize * SizeOf(Pointer));
        ZeroMemory(@(FData[DataRow][FColsInRow[DataRow]]), (NewSize - FColsInRow[DataRow]) * SizeOf(Pointer));

        ReAllocMem(FDataType[DataRow], NewSize * SizeOf(TtsValueType));
        ZeroMemory(@(FDataType[DataRow][FColsInRow[DataRow]]), (NewSize - FColsInRow[DataRow]) * SizeOf(TtsValueType));

        FColsInRow[DataRow] := NewSize;
        FColsAllocInRow[DataRow] := NewSize;
    end
    else if NewSize < FColsAllocInRow[DataRow] then
    begin
        ReAllocMem(FData[DataRow], NewSize * SizeOf(Pointer));
        ReAllocMem(FDataType[DataRow], NewSize * SizeOf(TtsValueType));
        FColsInRow[DataRow] := NewSize;
        FColsAllocInRow[DataRow] := NewSize;
    end
    else
        FColsInRow[DataRow] := NewSize;
end;

procedure Tts2DStorage.CheckCreateCol(DataCol, DataRow: Integer);
var
    AllocCols: Integer;
begin
    if DataCol > FColsInRow[DataRow] then
    begin
        if DataCol <= FColsAllocInRow[DataRow] then
            FColsInRow[DataRow] := DataCol
        else
        begin
            if DataCol < FColsAllocSize 
                then AllocCols := FColsAllocSize
                else AllocCols := DataCol + 10;
            ResizeRowCols(DataRow, AllocCols);
        end;
    end;
end;

procedure Tts2DStorage.SetValue(DataCol, DataRow: Integer; Value: Variant; ValueType: TtsValueType);
var
    CurValueType: TtsValueType;
    Temp: Integer;
begin
    CurValueType := GetValueType(DataCol, DataRow);
    if VarIsEmpty(Value) and (CurValueType = vtpNone) then Exit;

    CheckCreateRow(DataRow);
    CheckCreateCol(DataCol, DataRow);

    if VarIsEmpty(Value) or (ValueType = vtpNone) then
    begin
        ClearValue(DataCol, DataRow);
        ValueType := vtpNone;
    end
    else
    begin
        if ValueType in [vtpString, vtpPictureName] then
        begin
            if not (CurValueType in [vtpNone, vtpString, vtpPictureName]) then
                ClearValue(DataCol, DataRow);
            string(FData[DataRow][DataCol - 1]) := Value
        end
        else if ValueType = vtpInteger then
        begin
            if not (CurValueType in [vtpNone, vtpInteger]) then
                ClearValue(DataCol, DataRow);
            Integer(FData[DataRow][DataCol - 1]) := Value
        end
        else if ValueType = vtpPicture then
        begin
            if not (CurValueType in [vtpNone, vtpPicture]) then
            begin