| 发表于：2007-05-09 11:48:3511楼 得分:34 |
这是我写的代码
请新建一个工程，放一个图片框控件在窗体上，不改控件名称，放入以下代码
option explicit
'矩形结构
private type rect
left as long
top as long
right as long
bottom as long
end type
'操作类型
enum optype
none = 0
draw
drag
end enum
dim rc as rect '所画矩形
dim ot as optype '操作类型
dim m_x as long '当拖动矩形时，鼠标位置的 x 坐标
dim m_y as long '当拖动矩形时，鼠标位置的 y 坐标
private sub form_load（)
ot = none
with picture1
.scalemode = vbpixels
.autoredraw = false
.appearance = 0
end with
end sub
private sub form_resize（)
picture1.move scalex（8, vbpixels, scalemode), scaley（8, vbpixels, scalemode), _
scalewidth - scalex（16, vbpixels, scalemode), _
scaleheight - scaley（16, vbpixels, scalemode)
end sub
private sub picture1_mousedown（button as integer, shift as integer, x as single, y as single)
if vbleftbutton = （button and vbleftbutton) then
select case ot
case optype.none
with rc
if x > .left and x < .right and y > .top and y < .bottom then
'如果已经画好了矩形，如果点击矩形范围内任意位置，则视为拖动矩形
m_x = x
m_y = y
ot = drag
else
'反之则视为重画矩形
call drawrect
.left = x
.right = x
.top = y
.bottom = y
ot = draw
end if
end with
case optype.draw
case optype.drag
end select
end if
end sub
private sub picture1_mousemove（button as integer, shift as integer, x as single, y as single)
if vbleftbutton = （button and vbleftbutton) then
with rc
select case ot
case optype.none
case optype.draw
'画矩形时，先画一次清除上次画的矩形
call drawrect
'矩形的其中一个角不变
.right = x
.bottom = y
'再画新的矩形，达到移动矩形的目的
call drawrect
case optype.drag
'画矩形时，先画一次清除上次画的矩形
call drawrect
'移动整个矩形
.left = .left - m_x + x
.top = .top - m_y + y
.right = .right - m_x + x
.bottom = .bottom - m_y + y
m_x = x
m_y = y
'再画新的矩形，达到移动矩形的目的
call drawrect
end select
end with
end if
end sub
private sub picture1_mouseup（button as integer, shift as integer, x as single, y as single)
if vbleftbutton = （button and vbleftbutton) then
select case ot
case optype.none
case optype.draw
'为了下次拖动，将矩形调整好，左边比右边的坐标小，上边比下边坐标小
dim tmp as long
with rc
if .right < .left then
tmp = .right
.right = .left
.left = tmp
end if
if .bottom < .top then
tmp = .bottom
.bottom = .top
.top = tmp
end if
end with
case optype.drag
end select
ot = none
end if
end sub
'画矩形
private sub drawrect（)
with rc
if .right = .left or .bottom = .top then exit sub
dim drmode as integer
drmode = picture1.drawmode
picture1.drawmode = vbnotxorpen
picture1.line （.left, .top)-（.right, .bottom), vbred, b
picture1.drawmode = drmode
end with
end sub
'控件重画时，要重画矩形
private sub picture1_paint（)
picture1.cls
call drawrect
end sub
| | |
|
