Se me ha presentado la necesidad de poder copiar campos (SubItems) de un TListView y dado que la aplicación tiene muchos controles de ese tipo, decidí hacer un sistema sencillo de adaptar a los formularios, que tengan el citado componente y que me ahorrase reescribir código. La solución que he implementado es una clase que realiza un subclassing del ListView y le introduce un PopupMenu con la opción "copy". Si ya existía un menú previo asignado al ListView puede utilizar éste. El código de la clase está escrito primeramente en C++ y con API, de esta forma se puede adaptar a aplicaciones No VCL. Pero no os preocupéis, he hecho una traducción a delphi.
Para dejar claro que se ha hecho la copia del campo seleccionado, aparece un marquito en su borde durante 300 ms.
Es necesario incluir un archivo de recursos estilo WinXP
Vamos a exponer el código que está probado para delphi 6, 7 y Berlin.
unit ListViewCopy; //------------------------------------------------------------------------------ // TLVCopy V 3.0 // escafandra 2018 // Clase para permitir copiar al portapapeles un campo de texto de un ListView // tipo vsReport, visualiza el contorno del campo del Item copiado // Incluir recursos estilo WinXP interface uses Windows, Messages, CommCtrl; type {$IfnDef TLVITEMINDEX} TLVITEMINDEX = record iItem: integer; iGroup: integer; end; PLVITEMINDEX = ^TLVITEMINDEX; {$EndIf} TLVCopy = class private hListView: THANDLE; Window: THANDLE; OldListViewProc: Pointer; Menu: HMENU ; Point: TPOINT ; ItemIndex: integer; MenuIndex: integer; DeleteMenu: boolean; function ListViewProc(Handle: HWND; Msg: DWORD; WParam: DWORD; LParam: DWORD): DWORD; stdcall; function CopyText(Text: PAnsiChar): boolean; public destructor Destroy; override; procedure SetHandle(Handle: THANDLE; Text: PAnsiCHAR = nil; _menu: HMENU = 0; _menuIndex: integer = 0; Win: THANDLE = 0); procedure Copy(); end; const LVM_GETITEMINDEXRECT = (LVM_FIRST + 209); implementation function ListView_GetColumnCount(hListView: THANDLE): integer; var hHdr: HWND; begin hHdr:= SendMessage(hListView, LVM_GETHEADER, 0, 0); Result:= SendMessage(hHdr, HDM_GETITEMCOUNT, 0, 0); end; function ListView_HitTest(hListView: THANDLE; var IInfo: TLVHITTESTINFO): integer; begin Result:= SendMessage(hListView, LVM_HITTEST, 0, integer(@IInfo)); end; function ListView_GetItemIndexRect(hListView: THANDLE; var lvii: TLVITEMINDEX; SubItem, Code: cardinal; var Rect: TRect): integer; begin Rect.Top:= SubItem; Rect.Left:= Code; Result:= SendMessage(hListView, LVM_GETITEMINDEXRECT, Cardinal(@lvii), cardinal(@Rect)); end; function GetItemAndSubItem(hListView: THANDLE; X, Y: integer; var SubItem: integer): integer; var IInfo: TLVHITTESTINFO; ItemIndex, Columns, ComentLeft: integer; begin IInfo.pt.x:= 5; IInfo.pt.y:= Y; ItemIndex:= ListView_HitTest(hListView, IInfo); Columns:= ListView_GetColumnCount(hListView); ComentLeft:= 0; SubItem:= -1; repeat inc(SubItem); ComentLeft:= ComentLeft + ListView_GetColumnWidth(hListView, SubItem); until (X < ComentLeft) or (SubItem >= Columns - 1); if X > ComentLeft then SubItem:= -1; Result:= ItemIndex; end; // SubItem = 0 para Caption function GetRect(hListView: THANDLE; ItemIndex, SubItem: integer): TRect; var lvii: TLVITEMINDEX; begin lvii.iItem:= ItemIndex; ListView_GetItemIndexRect(hListView, lvii, SubItem, LVIR_BOUNDS, Result); if SubItem = 0 then Result.right:= Result.left + ListView_GetColumnWidth(hListView, 0); end; //--------------------------------------------------------------------------- // SubItem = 0 para Caption procedure DrawFrameRect(hListView: THANDLE; ItemIndex, SubItem: integer; Color: TCOLORREF); var R: TRect; DC: HDC; Pen: HPEN; begin R:= GetRect(hListView, ItemIndex, SubItem); DC:= GetDC(hListView); Pen:= CreatePen(PS_SOLID, 3, Color); SelectObject(DC, GetStockObject(NULL_BRUSH)); SelectObject(DC, Pen); Rectangle(DC, R.left, R.top, R.right, R.bottom); DeleteObject(Pen); ReleaseDC(hListView, DC); end; procedure TLVCopy.Copy; var Item: TLVITEMA; Si: integer; R: TRect; Buffer: array [0..511] of AnsiCHAR; begin // Obtengo ItemIndex y SubItem ItemIndex:= GetItemAndSubItem(hListView, Point.x, Point.y, Si); // Leyendo el texto a copiar Item.iItem:= ItemIndex; Item.iSubItem:= Si; Item.pszText:= Buffer; Item.cchTextMax:= sizeof(Buffer); // Copiando al ClipBoard y pintando el marco if SendMessage(hListView, LVM_GETITEMTEXTA, ItemIndex, integer(@Item))>0 then begin // Copiando al ClipBoard if CopyText(Buffer) then begin // Pintando el marco para confirmar DrawFrameRect(hListView, ItemIndex, Si, $FFFF00); Sleep(300); R:= GetRect(hListView, ItemIndex, Si); InflateRect(R, 1, 1); InvalidateRect(hListView, @R, true); end; end; end; function DefListViewProc(Handle: HWND; Msg: DWORD; WParam: DWORD; LParam: DWORD): DWORD; stdcall; var pLVCopy: TLVCopy; begin pLVCopy:= TLVCopy(GetWindowLong(Handle, GWL_USERDATA)); if pLVCopy <> nil then Result:= pLVCopy.ListViewProc(Handle, Msg, WParam, LParam) else Result:= DefWindowProc(Handle, Msg, WParam, LParam); end; function TLVCopy.ListViewProc(Handle: HWND; Msg: DWORD; WParam: DWORD; LParam: DWORD): DWORD; stdcall; var ScrPoint: TPoint; Si, Item: integer; begin if Msg = WM_CONTEXTMENU then begin // ScrPoint.x:= LParam and $FFFF; // ScrPoint.y:= LParam shr 16; GetCursorPos(ScrPoint); Point:= ScrPoint; ScreenToClient(Handle, Point); Item:= GetItemAndSubItem(hListView, Point.x, Point.y, Si); if (Item >= 0) and (Si>=0) then begin TrackPopupMenuEx(Menu, 0, ScrPoint.x, ScrPoint.y, hListView, nil); Result:= DefWindowProc(Handle, Msg, WParam, LParam); Exit; end; end else if Msg = WM_COMMAND then begin if WParam = cardinal(MenuIndex) then Copy; // Copio el campo al portapapeles if (WParam and $0000FFFF) <> 0 then // Se rebota el mensaje para que la ventana de tratamiento del menú ya existente // pueda tratar el comando PostMessage(Window, WM_COMMAND, WParam, 0); end; Result:= CallWindowProc(OldListViewProc, Handle, Msg, WParam, LParam); end; // Cuando ya se dispone de un menú, se puede usar pasando su Handle, el Index para // activar el Copy y la ventana de tratamiento de mensajes del menú existente procedure TLVCopy.SetHandle(Handle: THANDLE; Text: PAnsiCHAR = nil; _menu: HMENU = 0; _menuIndex: integer = 0; Win: THANDLE = 0); begin if (hListView <> 0) or (Handle = INVALID_HANDLE_VALUE) or (Handle = 0) then if hListView <> 0 then begin SetWindowLong(hListView, GWL_USERDATA, 0); SetWindowLong(hListView, GWL_WNDPROC, LongInt(OldListViewProc)); hListView:= 0; if DeleteMenu then DestroyMenu(Menu); end; if (Handle <> INVALID_HANDLE_VALUE) and (Handle <> 0) then begin hListView:= Handle; SetWindowLong(hListView, GWL_USERDATA, LongInt(self)); OldListViewProc:= Pointer(SetWindowLong(hListView, GWL_WNDPROC, LongInt(@DefListViewProc))); if _menu <> INVALID_HANDLE_VALUE then begin if _menu <> 0 then begin Menu:= _menu; Window:= Win; MenuIndex:= _menuIndex; DeleteMenu:= false; if Text <> nil then InsertMenuA(Menu, 0, MF_POPUP or MF_BYPOSITION, MenuIndex, Text); end else begin Menu:= CreatePopupMenu(); MenuIndex:= 0; if Text <> nil then InsertMenuA(Menu, 0, MF_POPUP, MenuIndex, Text) else InsertMenuA(Menu, 0, MF_POPUP, MenuIndex, 'Copiar Campo'); DeleteMenu:= true; end; end; end; end; function TLVCopy.CopyText(Text: PAnsiCHAR): boolean; var clBuffer: HGLOBAL; GBuffer: PAnsiCHAR; begin Result:= OpenClipboard(hListView); if Result then begin EmptyClipboard(); clBuffer:= GlobalAlloc(GMEM_DDESHARE, lstrlenA(Text)+1); GBuffer:= GlobalLock(clBuffer); lstrcpyA(GBuffer, Text); GlobalUnlock(clBuffer); SetClipboardData(CF_TEXT, clBuffer); CloseClipboard(); end; end; destructor TLVCopy.Destroy; begin SetHandle(0); end; end.
La forma de uso es bien sencilla, se precisa una instancia TLVCopy por cada TListView al que queramos dotar de la opción copy. A la instancia se le asigna el Handle del TListView y listo:
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, ListViewCopy; type TForm1 = class(TForm) ListView: TListView; procedure FormCreate(Sender: TObject); private LVCopy: TLVCopy; public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.FormCreate(Sender: TObject); begin LVCopy:= TLVCopy.Create; LVCopy.SetHandle(ListView.Handle); end; procedure TForm1.FormDestroy(Sender: TObject); begin LVCopy.Free; end; end.
Para que el código sea compatible en versiones antiguas, he optado por descartar UNICODE aunque esto es transparente al uso de la clase, es importante decirlo por si alguno quiere meterle mano.
Características:
1. Usa la técnica del subclassing con API pura.
2. Cada Instancia controla un TListView.
3. Crea un PopupMenu con la opción de copiar.
4. Una vez copiado el texto, remarca el campo con un marquito durante 300 ms.
5. El Texto del Item del menú se puede personalizar.
6. Si ya existe un menú previo, se puede pasar como parámetro y elegir si LVCopy añade el Item al menú o lo añadimos nosotros. También pasaremos el valor Item.Comand del MenuItem.
7. Usa Texto no Unicode.
8. La versión delphi requiere destruir la instancia, no así la C++, a no ser que esté creada como un puntero.
Saludos.