Page History
この例には、部門、セクション、社員のツリー・ビューがあります。ドラッグ・アンド・ドロップにより社員をセクション間で移動できます。
社員をドラッグ・アンド・ドロップするツリーのソース
このソースをコピーしてフォームに貼り付け、コンパイルして実行してください。この例が動作するためには、DD_EMPPL Payloadのソースを再利用可能パーツとしてコンパイルしておく必要があります。
...
FUNCTION options(*DIRECT)
BEGIN_
...
COM role(*
...
EXTENDS #PRIM_FORM)
...
CAPTION('
...
Move Employees')
...
HEIGHT(359)
...
LAYOUTMANAGER(#ATLM_1)
...
LEFT(304)
...
TOP(112)
...
WIDTH(274)
DEFINE_
...
COM class(#PRIM_ATLM)
...
name(#ATLM_1)
DEFINE_
...
COM class(#PRIM_TRVW)
...
name(#TRVW_1)
...
DISPLAYPOSITION(1)
...
DRAGSTYLE(Automatic)
...
HEIGHT(332)
...
LEFT(0)
...
PARENT(#COM_OWNER)
...
TABPOSITION(1)
...
TOP(0)
...
WIDTH(266)
DEFINE_
...
COM class(#PRIM_TVCL)
...
name(#TVCL_1)
...
DISPLAYPOSITION(1)
...
KEYPOSITION(1)
...
LEVEL(1)
...
PARENT(#TRVW_1)
...
SORTPOSITION(1)
...
SOURCE(#DEPTMENT)
DEFINE_
...
COM class(#PRIM_TVCL)
...
name(#TVCL_2)
...
DISPLAYPOSITION(1)
...
KEYPOSITION(1)
...
LEVEL(2)
...
PARENT(#TRVW_1)
...
SORTPOSITION(1)
...
SOURCE(#SECTION)
DEFINE_
...
COM class(#PRIM_TVCL)
...
name(#TVCL_3)
...
DISPLAYPOSITION(1)
...
KEYPOSITION(1)
...
LEVEL(3)
...
PARENT(#TRVW_1)
...
SORTPOSITION(1)
...
SOURCE(#EMPNO)
DEFINE_
...
COM class(#PRIM_ATLI)
...
name(#ATLI_1)
...
ATTACHMENT(Center)
...
MANAGE(#TRVW_1)
...
PARENT(#ATLM_1)
DEFINE_
...
COM class(#PRIM_STBR)
...
name(#STBR_1)
...
DISPLAYPOSITION(2)
...
HEIGHT(24)
...
LEFT(0)
...
MESSAGEPOSITION(1)
...
PARENT(#COM_OWNER)
...
TABPOSITION(2)
...
TABSTOP(False)
...
TOP(308)
...
WIDTH(266)
DEFINE_
...
COM class(#PRIM_ATLI)
...
name(#ATLI_4)
...
ATTACHMENT(Bottom)
...
PARENT(#ATLM_1)
...
* Employee Payload object
DEFINE_COM class(#dd_emppl)
...
name(#PAYLOAD)
...
reference(*dynamic)
...
DEFINE field(#W_EMPNO)
...
reffld(#EMPNO)
...
DEFINE field(#W_DEPT)
...
reffld(#DEPTMENT)
...
DEFINE field(#W_SECT)
...
reffld(#SECTION)
...
EVTROUTINE handling(#com_owner.CreateInstance)
...
options(*
...
NOCLEARERRORS *NOCLEARMESSAGES)
...
* Tree view images
SET com(#tvcl_1)
...
IMAGE(#vi_foldcl)
...
IMAGEEXPANDED(#vi_foldop)
...
SET com(#tvcl_2)
...
IMAGE(#vi_sectcl)
...
IMAGEEXPANDED(#vi_sectop)
...
SET com(#tvcl_3)
...
IMAGE(#vi_employ)
...
* Populate Tree
SELECT fields(#TRVW_1)
...
from_file(DEPTAB)
...
SELECT fields(#TRVW_1)
...
from_file(SECTAB)
...
with_key(#DEPTMENT)
...
SELECT fields(#TRVW_1)
...
from_file(PSLMST1)
...
with_key(
...
#DEPTMENT #SECTION)
ADD_
...
ENTRY to_list(#TRVW_1)
ENDSELECT
ENDSELECT
ENDSELECT
ENDROUTINE
...
* Start the drag operation.
* Only allow employees to be "dragged"
...
EVTROUTINE handling(#TRVW_1.StartDrag)
...
options(*
...
NOCLEARMESSAGES *NOCLEARERRORS)
...
CONTINUE(#continue)
...
USE builtin(CLR_MESSAGES)
...
* Create Payload Instance
SET_REF com(#payload)
...
to(*create_
...
as #dd_emppl)
...
* Only allow employee to be dragged
IF cond('#Trvw_1.currentitem.
...
level =
...
3')
...
* Add item to the payload
INVOKE method(#Payload.Add_to_payload)
...
EMPLOYEE_ID(#empno)
...
EMPLOYEE_DEPARTMENT(#deptment)
...
EMPLOYEE_SECTION(#section)
...
ELSE
SET com(#continue)
...
VALUE(false)
ENDIF
...
ENDROUTINE
EVTROUTINE handling(#TRVW_1.DragOver)
...
options(*
...
NOCLEARERRORS *NOCLEARMESSAGES)
...
ACCEPTDROP(#acceptdrop)
...
SHOWDROPHILIGHT(#ShowHilight)
...
* Show Item dragged over
SET com(#showhilight)
...
VALUE(true)
...
* If a department, employee cannot be dropped
IF_REF com(#trvw_1.currentitem)
...
is_not(*null)
...
IF cond('(#trvw_1.currentitem.
...
level *ne 1)')
...
* Allow drop and set new cursor
SET com(#acceptdrop)
...
VALUE(true)
...
ELSE
...
* Disable drop
SET com(#acceptdrop)
...
VALUE(False)
...
ENDIF
...
ENDIF
...
ENDROUTINE
EVTROUTINE handling(#TRVW_1.DragDrop)
...
options(*
...
NOCLEARERRORS *NOCLEARMESSAGES)
...
* If the payload is not empty, get the payload item and add to the treeview in the new section
IF cond('#Payload.Payload_
...
Items *
...
ne *zero')
...
* Return values in to working fields fields to compare with current item values
INVOKE method(#Payload.Get_Payload_Item)
...
PAYLOAD_ITEM(1)
...
EMPLOYEE_ID(#empno)
...
EMPLOYEE_DEPARTMENT(#w_dept)
...
EMPLOYEE_SECTION(#w_sect)
...
* If the department and/or section have changed, do the drop
IF cond('(#deptment *ne #W_dept) or (#section *ne #w_sect)')
...
* Department and section values of currentitem are used
ADD_ENTRY to_list(#TRVW_1)
...
MESSAGE msgtxt(' Drop Successful')
...
* Expand Parent items of new drop point
* As drop can only happen on a section, department must be expanded
CHANGE field(#W_DEPT)
...
to(#DEPTMENT)
...
CHANGE field(#W_SECT)
...
to(#section)
...
SELECTLIST named(#TRVW_1)
...
CONTINUE if('#w_
...
dept *ne #deptment')
...
CONTINUE if('#w_
...
sect *ne #section')
...
SET com(#trvw_1.currentitem)
...
EXPANDED(true)
...
LEAVE
ENDSELECT
...
ENDIF
...
ENDIF
...
ENDROUTINE
EVTROUTINE handling(#TRVW_1.EndDrag)
...
options(*
...
NOCLEARERRORS *NOCLEARMESSAGES)
...
DRAGRESULT(#DragResult)
...
IF cond('#Dragresult.
...
value =
...
Accepted')
...
* If the department and/or section have changed delete the source employee
IF cond('(#deptment *ne #w_dept) or (#section *ne #w_sect)')
...
* Get payload item details
INVOKE method(#Payload.Get_Payload_Item)
...
PAYLOAD_ITEM(1)
...
EMPLOYEE_ID(#w_empno)
...
EMPLOYEE_DEPARTMENT(#w_dept)
...
EMPLOYEE_SECTION(#w_sect)
...
* Locate and Delete source employee
SELECTLIST named(#TRVW_1)
...
CONTINUE if('#w_
...
dept *ne #deptment')
...
CONTINUE if('#w_
...
sect *ne #section')
...
CONTINUE if('#w_
...
empno *ne #empno')
...
DLT_
...
ENTRY from_list(#TRVW_1)
...
LEAVE
ENDSELECT
...
ENDIF
ENDIF
ENDROUTINE
END_COM