xlsmapparser3.pas

Advanced Data Import Component Suite for Borland Delphi and C++ Builder allows you to import your da

end;

function OptimizeString(const Str: string): string;

function CanBeUnion(const Str1, Str2: string; var Str3: string): boolean;
var
  rt1, rt2: TRangeType;
  c1, r1, c2, r2, c3, r3, c4, r4: integer;
begin
  Result := false;

  rt1 := GetRangeType(Str1);
  rt2 := GetRangeType(Str2);

  if rt1 = rtCell then Str2ColRow(Str1, c1, r1)
  else Str2Range(Str1, c1, r1, c2, r2);
  if rt2 = rtCell then Str2ColRow(Str2, c4, r4)
  else Str2Range(Str2, c3, r3, c4, r4);

  case rt1 of
    rtCell: case rt2 of
              rtCell: Result := ((c1 = c4) and (Abs(r4 - r1) = 1)) or
                                ((r1 = r4) and (Abs(c1 - c4) = 1));
              rtCol : Result := (c1 = c3) and (Abs(r3 - r1) = 1);
              rtRow : Result := (r1 = r3) and (Abs(c3 - c1) = 1);
            end;
    rtCol : case rt2 of
              rtCell: Result := (c2 = c4) and (Abs(r4 - r2) = 1);
              rtCol : Result := (c1 = c3) and (Abs(r3 - r2) = 1);
            end;
    rtRow : case rt2 of
              rtCell: Result := (r2 = r4) and (Abs(c4 - c2) = 1);
              rtRow : Result := (r1 = r3) and (Abs(c3 - c2) = 1);
            end;
  end;
  if Result then begin
    Str3 := Col2Letter(c1) + Row2Number(r1);;
    if ((c1 = c4) and (r1 <> r4)) or ((r1 = r4) or (c1 <> c4)) then
      Str3 := Str3 + '-' + Col2Letter(c4) + Row2Number(r4);
  end;
end;

var
  p, p1, p11, p2: string;
  i, j: integer;
begin
  Result := Trim(Str);
  if Result = EmptyStr then Exit;
//!!!  if not CheckStringOfCells(nil, Result) then Exit;
  if Str[Length(Result)] <> ';' then Result := Str + ';';
  Result := UpperCase(Result);

  i := 1;
  j := 1;
  while i <= Length(Result) do begin
    p1 := EmptyStr;
    p2 := EmptyStr;
    while (i <= Length(Result)) and (Result[i] <> ';') do begin
      p1 := p1 + Result[i];
      Inc(i);
    end;
    p11 := CheckRange(p1);
    if CompareText(p11, p1) <> 0 then begin
      Delete(Result, i - Length(p1), Length(p1));
      Insert(p11, Result, i - Length(p1));
      Inc(i, Length(p11) - Length(p1));
    end;
    Inc(i);
    while (i <= Length(Result)) and (Result[i] <> ';') do begin
      p2 := p2 + Result[i];
      Inc(i);
    end;
    p11 := CheckRange(p2);
    if CompareText(p11, p2) <> 0 then begin
      Delete(Result, i - Length(p2), Length(p2));
      Insert(p11, Result, i - Length(p2));
      Inc(i, Length(p11) - Length(p2));
    end;
    if (p1 = EmptyStr) or (p2 = EmptyStr) then Exit;
    if CanBeUnion(p1, p2, p) then begin
      p := p + ';';
      Delete(Result, j, i - j + 1);
      Insert(p, Result, j);
      i := j;
    end
    else begin
      i := i - Length(p2);
      j := i;
    end;
  end;
end;

function SkipFirstRows(const Str: string; Rows: integer): string;
var
  k, j, c1, r1, c2, r2: integer;
  ss: string;
begin
  Result := Str;
  if Rows <= 0 then Exit;
  k := 1;
  j := Pos(';', Copy(Result, k, Length(Str) - k + 1));
  if (j = 0) and (Length(Str) > 0) then
    j := Length(Str);
  ss := Copy(Result, k, j - k + 1);
  while ss <> EmptyStr do begin
    case GetRangeType(ss) of
      rtCol: begin
        Str2Range(ss, c1, r1, c2, r2);
        if Rows <= r2 - r1 then
          ss := Col2Letter(c1) + Row2Number(Trunc(MaxValue([1 + Rows, r1]))) + '-' +
                Col2Letter(c2) + Row2Number(Trunc(MaxValue([1 + Rows, r2]))) + ';'
        else ss := EmptyStr;
        Delete(Result, k, j - k + 1);
        Insert(ss, Result, k);
        k := k + Length(ss);
      end;
      rtRow: begin
        Str2Range(ss, c1, r1, c2, r2);
        if r1 <= Rows then Delete(Result, k, j - k + 1)
        else k := k + Length(ss);
      end;
      rtCell: begin
        Str2ColRow(ss, c1, r1);
        if r1 <= Rows then Delete(Result, k, j - k + 1)
        else k := k + Length(ss);
      end;
    end;
    j := Pos(';', Copy(Result, k, Length(Result) - k + 1)) + k - 1;
    ss := Copy(Result, k, j - k + 1);
  end;
end;

function SkipFirstCols(const Str: string; Cols: integer): string;
var
  k, j, c1, r1, c2, r2: integer;
  ss: string;
begin
  Result := Str;
  if Cols <= 0 then Exit;
  k := 1;
  j := Pos(';', Copy(Result, k, Length(Result) - k + 1));
  if (j = 0) and (Length(Str) > 0) then
    j := Length(Str);
  ss := Copy(Result, k, j - k + 1);
  while ss <> EmptyStr do begin
    case GetRangeType(ss) of
      rtCol: begin
        Str2Range(ss, c1, r1, c2, r2);
        if c1 <= Cols then Delete(Result, k, j - k + 1)
        else k := k + Length(ss);
      end;
      rtRow: begin
        Str2Range(ss, c1, r1, c2, r2);
        if Cols <= c2 - c1 then
          ss := Col2Letter(Trunc(MaxValue([1 + Cols, c1]))) + Row2Number(r1) + '-' +
                Col2Letter(Trunc(MaxValue([1 + Cols, c2]))) + Row2Number(r2) + ';'
        else ss := EmptyStr;
        Delete(Result, k, j - k + 1);
        Insert(ss, Result, k);
        k := k + Length(ss);
      end;
      rtCell: begin
        Str2ColRow(ss, c1, r1);
        if c1 <= Cols then Delete(Result, k, j - k + 1)
        else k := k + Length(ss);
      end;
    end;
    j := Pos(';', Copy(Result, k, Length(Result) - k + 1)) + k - 1;
    ss := Copy(Result, k, j - k + 1);
  end;
end;

function CheckRange(const Str: string): string;
var
  c1, r1, c2, r2: integer;
begin
  Result := Trim(Str);
  if Result = EmptyStr then Exit;
//!!!  if not CheckStringOfCells(nil, Result) then Exit;
  Result := UpperCase(Result);
  if Pos('-', Result) = 0 then Exit;
  Str2Range(Result, c1, r1, c2, r2);
  if (c1 = c2) and (r1 = r2) then
    Delete(Result, Pos('-', Result), Length(Result) - Pos('-', Result) + 1);
end;

{ TMapRange }

constructor TMapRange.Create(MapRow: TMapRow);
begin
  inherited Create;;
  FMapRow := MapRow;
  if Assigned(FMapRow) then
    FXLSFile := FMapRow.XLSFile;

  FDirection := rdUnknown;
  FSheetIDType := sitUnknown;
  FSheetNumber := 0;
  FSheetName := EmptyStr;
  FRow1 := 0;
  FCol1 := 0;
  FRow2 := 0;
  FCol2 := 0;
end;

procedure TMapRange.Arrange;
var
  SheetIndex, Index: integer;
begin
  Update;
  if not Assigned(FXLSFile) then Exit;

  if not FXLSFile.Loaded then
    FXLSFile.Load;

  if GetHasSheet then
  begin
    if FSheetNumber > 0 then
      SheetIndex := FSheetNumber - 1
    else
      SheetIndex := FXLSFile.Workbook.WorkSheets.IndexOfName(FSheetName);

    if SheetIndex = -1 then
      raise Exception.CreateFmt(sSheetNotFound, [FSheetName]);
  end
  else
    SheetIndex := 0;

  if FRangeType = rtRow then
  begin
    if not FXLSFile.Workbook.WorkSheets[SheetIndex].Rows.Find(FRow1 - 1, Index) then
      raise Exception.CreateFmt(sRowNotFound, [FRow1, FSheetName]);

    if FCol1 = 0 then
    begin
      if FDirection = rdDown then
        FCol1 := FXLSFile.Workbook.WorkSheets[SheetIndex].Rows[Index].MinCol + 1
      else if FDirection = rdUp then
        FCol1 := FXLSFile.Workbook.WorkSheets[SheetIndex].Rows[Index].MaxCol + 1;
    end;

    if FCol2 = 0 then
    begin
      if FDirection = rdDown then
        FCol2 := FXLSFile.Workbook.WorkSheets[SheetIndex].Rows[Index].MaxCol + 1
      else if FDirection = rdUp then
        FCol2 := FXLSFile.Workbook.WorkSheets[SheetIndex].Rows[Index].MinCol + 1;
    end;    
  end
  else if FRangeType = rtCol then
  begin
    if not FXLSFile.Workbook.WorkSheets[SheetIndex].Cols.Find(FCol1 - 1, Index) then
      raise Exception.CreateFmt(sColNotFound, [FCol1, FSheetName]);

    if FRow1 = 0 then
    begin
      if FDirection = rdDown then
        // pai 
        //FRow1 := FXLSFile.Workbook.WorkSheets[SheetIndex].Cols[Index].MinRow + 1
        FRow1 := 1
        // pai
      else if FDirection = rdUp then
        FRow1 := FXLSFile.Workbook.WorkSheets[SheetIndex].Cols[Index].MaxRow + 1;
    end;

    if FRow2 = 0 then
    begin
      if FDirection = rdDown then
        FRow2 := FXLSFile.Workbook.WorkSheets[SheetIndex].Cols[Index].MaxRow + 1
      else if FDirection = rdUp then
        FRow2 := FXLSFile.Workbook.WorkSheets[SheetIndex].Cols[Index].MinRow + 1;
    end;
  end;
  Update;
end;

function TMapRange.GetHasSheet: boolean;
begin
  Result := (FSheetName <> EmptyStr) or (FSheetNumber > 0)
end;

procedure TMapRange.Update;
var
  T1, T2, S: integer;
begin
  FRangeType := rtUnknown;
  if (FCol1 > 0) and (FRow1 > 0) and (FCol2 > 0) and (FRow2 > 0) and
     (FCol1 = FCol2) and (FRow1 = FRow2) then
     FRangeType := rtCell
  else if (FCol1 > 0) or (FRow1 > 0) or (FCol2 > 0) or (FRow2 > 0) then
  begin
    if (FCol1 = FCol2) and (FCol1 > 0) then
      FRangeType := rtCol
    else if (FRow1 = FRow2) and (FRow1 > 0) then
      FRangeType := rtRow
  end;

  FLength := 0;
  case FRangeType of
    rtCell:
      if (FRow1 <= SkipFirstRows) or (FCol1 <= SkipFirstCols)
        then FLength := 0
        else FLength := 1;
    rtRow :
      if FRow1 <= SkipFirstRows then
        FLength := 0
      else begin
        S := SkipFirstCols;

        if (FCol1 <= S) and (FCol2 <= S) then
          FLength := 0
        else begin
          if FCol1 <= S
            then T1 := S + 1
            else T1 := FCol1;
          if FCol2 <= S
            then T2 := S + 1
            else T2 := FCol2;
          FLength := Abs(T2 - T1) + 1;
        end;
        //FLength := Abs(FCol2 - FCol1) + 1;
      end;
    rtCol :
      if FCol1 <= SkipFirstCols then
        FLength := 0
      else begin
        S := SkipFirstRows;

        if (FRow1 <= S) and (FRow2 <= S) then
          FLength := 0
        else begin
          if FRow1 <= S
            then T1 := S + 1
            else T1 := FRow1;
          if FRow2 <= S
            then T2 := S + 1
            else T2 := FRow2;
          FLength := Abs(T2 - T1) + 1;
        end;
        //FLength := Abs(FRow2 - FRow1) + 1;
      end;
  end;
end;

procedure TMapRange.Assign(Range: TMapRange);
begin
  FCol1 := Range.Col1;
  FRow1 := Range.Row1;
  FCol2 := Range.Col2;
  FRow2 := Range.Row2;
  FDirection := Range.Direction;
  FSheetIDType := Range.SheetIDType;
  FSheetNumber := Range.SheetNumber;
  FSheetName := Range.SheetName;
  Update;
end;

procedure TMapRange.UpdateDirection;
begin
  case FRangeType of
    rtCol:
      if (Row1 > 0) and (Row2 > 0) then
        if Row1 < Row2 then FDirection := rdDown
        else if Row1 > Row2 then FDirection := rdUp;
    rtRow:
      if (Col1 > 0) and (Col2 > 0) then
        if Col1 < Col2 then FDirection := rdDown
        else if Col1 > Col2 then FDirection := rdUp;
    rtCell: FDirection := rdUnknown;
  end;
end;

function TMapRange.GetAsString: string;
begin
  Result := EmptyStr;
  if SheetIDType <> sitUnknown then begin
    Result := Result + SHEET_START;
    if SheetIDType = sitNumber
      then Result := Result + SHEET_NUMBER + IntToStr(FSheetNumber)
      else Result := Result + FSheetName;
    Result := Result + SHEET_FINISH;
  end;
  case FRangeType of
    rtCell: Result := Result + Col2Letter(FCol1) + Row2Number(FRow1);
    rtCol: begin
      if (FRow1 > 0) and (FRow2 > 0) then
        Result := Result + Col2Letter(FCol1) + Row2Number(FRow1) +
          ARRAY_DELIMITER + Col2Letter(FCol2) + Row2Number(FRow2)
      else
        case FDirection of