uses .., HTMLDefs, .... TCustomStringGrid = class(TCustomDrawGrid) ... protected ... procedure SelectionSetHTML(TheHTML: String); .... procedure TCustomStringGrid.CopyCellRectToClipboard(const R: TRect); var SelStr, SelHTMLStr: String; aRow,aCol,k: LongInt; function PrepareToTXT(s: string): string; begin DoCellProcess(aCol, aRow, cpCopy, s); if (pos(#9, s)>0) or //Excel and Calc convert tab symbol # 9 in cell to whitespace. (pos(#10, s)>0) or (pos(#13, s)>0) or (pos('"', s)>0) then result := AnsiQuotedStr(s, '"') else result := s; end; function PrepareToHTML(s: string): string; var i1: Integer; s1: string; begin Result := ''; for i1 := 1 to Length(s) do begin case s[i1] of #13: s1 := '
'; #10: if i1 > 1 then if s[i1 - 1] = #13 then s1 := '' else s1 := '
'; '<': s1 := '<'; '>': s1 := '>'; '"': s1 := '"'; '&': s1 := '&'; else s1 := s[i1]; end; Result := Result + s1; end; end; begin SelStr := ''; SelHTMLStr := ''; for aRow := R.Top to R.Bottom do begin SelHTMLStr := SelHTMLStr + ''; for aCol := R.Left to R.Right do begin if Columns.Enabled and (aCol >= FirstGridColumn) then begin k := ColumnIndexFromGridColumn(aCol); if not Columns[k].Visible then continue; if (aRow = 0) and (FixedRows > 0) then begin SelStr := SelStr + PrepareToTXT(Columns[k].Title.Caption); SelHTMLStr := SelHTMLStr + ''; end else begin SelStr := SelStr + PrepareToTXT(Cells[aCol,aRow]); SelHTMLStr := SelHTMLStr + ''; end; end else begin SelStr := SelStr + PrepareToTXT(Cells[aCol,aRow]); SelHTMLStr := SelHTMLStr + ''; end; if aCol <> R.Right then SelStr := SelStr + #9; end; SelStr := SelStr + sLineBreak; SelHTMLStr := SelHTMLStr + ''; end; SelHTMLStr := SelHTMLStr + '
' + PrepareToHTML(Columns[k].Title.Caption) + '' + PrepareToHTML(Cells[aCol,aRow]) + '' + PrepareToHTML(Cells[aCol,aRow]) + '
'; Clipboard.SetAsHtml(SelHTMLStr, SelStr); end; procedure TCustomStringGrid.DoPasteFromClipboard; begin // Unpredictable results when a multiple selection is pasted back in. // Therefore we inhibit this here. if HasMultiSelection then exit; if EditingAllowed(Col) then begin if Clipboard.HasFormat(CF_TEXT) and not Clipboard.HasFormat(CF_HTML) then SelectionSetText(Clipboard.AsText); if Clipboard.HasFormat(CF_TEXT) and Clipboard.HasFormat(CF_HTML) then SelectionSetHTMLNew(Clipboard.GetAsHtml(True)); end; end; procedure TCustomStringGrid.SelectionSetHTMLNew(TheHTML: String); var StartCol,StartRow, aCol, aRow: Integer; p, q, t, endRow: pchar; theStr: string; theTmpHTML: string; replCount: Integer; SelRect: TRect; procedure NewRow; begin inc(aRow); aCol := startCol - 1; end; procedure NewCol; begin inc(aCol); end; function NextColRow(aTag:string): boolean; var a: pchar; isRow: boolean; begin q := nil; isRow := aTag='tr'; a := strpos(p, pchar('<'+aTag)); result := a<>nil; if result then begin inc(a); a := strscan(a, '>'); result := a<>nil; if result then begin // found, advance to content p := a + 1; // now find end of element q := strpos(p, pchar('nil; // update col, row if isRow then begin NewRow; if result then begin endRow := q + 4; q^ := #0; // put limits for any columns on this row end; end else NewCol; end; end; end; function RemoveAllTag(const aStr: string): string; var bTag: string; bStr, bEndStr: PChar; begin Result := ''; if aStr <> '' then begin bStr := PChar(aStr); bEndStr := bStr + StrLen(bStr) - 4; while bStr < bEndStr do begin if bStr^ = '<' then begin bTag := '<'; Inc(bStr); if UpCase(bStr^) = 'B' then begin Inc(bStr); if UpCase(bStr^) = 'R' then Result := Result + #10; //
end; if bStr^ = '/' then begin bTag := ''; // if UpCase(bStr^) = 'D' then Result := Result + bTag + 'td>'; // end; while bStr < bEndStr do begin Inc(bStr); if bStr^ = '>' then begin Inc(bStr); Break; end; end; end else begin if (bStr^ <> #13) and (bStr^ <> #10) and (bStr^ <> #9) then Result := Result + bStr^; Inc(bStr); end; end; end; end; function ReplaceEntities(st: string): string; var o,a,b: pchar; aName: widestring; entity: WideChar; begin while true do begin result := st; if st='' then break; o := @st[1]; a := strscan(o, '&'); if a=nil then break; b := strscan(a+1, ';'); if b=nil then break; aName := UTF8Decode(copy(st, a-o+2, b-a-1)); entity := ' '; if ResolveHTMLEntityReference(aName, entity) then begin system.delete(st, a-o+1, b-a+1); system.insert(UTF8Encode(entity), st, a-o+1); end; end; end; begin SelRect := Selection; StartCol := Selection.Left; StartRow := Selection.Top; aCol := startCol - 1; aRow := startRow - 1; //replace tag
to #10, remove all tag, except , , , . theTmpHTML := RemoveAllTag(theHTML); p := @theTmpHTML[1]; t := p + Length(theTmpHTML); // find next row if not NextColRow('tr') then begin NewRow; endRow := t; end; while p<>nil do begin // find all cells while p<>nil do begin if not NextColRow('td') then break; SetString(theStr, p, q-p); if (aCol < ColCount) and (aRow < RowCount) then Cells[aCol, aRow] := ReplaceEntities(theStr); end; p := endRow; // next row if not NextColRow('tr') then break; end; //need to corect set selection. SelRect.Right := aCol; SelRect.Bottom := aRow; Selection := SelRect; end;