【Access小品】戏说钓鱼式拖动复制

todaynew

上海一司机被钓鱼式执法，愤而断指，世人皆振臂疾呼，正义终得伸张。北大医院教授死亡，央视暗访报道，当事者指为钓鱼执法。有好事者云：该钓不该钓只有天知道！

    无论公理婆理，钓鱼总为一法。既是一法，便也就可于Access中运用，如拖放复制者，可以钓鱼之法施之耳。其原理为：以一控件为钩，以一控件为饵，以众控件为鱼，其挂饵、寻鱼、起钩者，即为拖放复制者也。

    姜太公所钓非鱼，天下也；蓑笠翁所钓非雪，清幽也；todaynew者所钓非数据，愉悦也。

todaynew

Public Sub 挂饵(钓钩 As Control, ctl As Control)
钓钩.Visible = True
钓钩.Move ctl.Left + 200, ctl.Top, ctl.Width, IIf(ctl.Height > 300, 300, ctl.Height)
钓钩.BorderStyle = 0
钓钩.BackStyle = 1
钓钩.BackColor = RGB(150, 200, 200)
钓钩.Value = ctl.Value
钓钩.SetFocus
End Sub

Public Function 寻鱼(frm As Form, x As Single, y As Single) As Control
Dim ctl As Control
On Error GoTo 寻鱼_Err
For Each ctl In frm.Controls
    If ctl.Name <> "钓钩" Then
        If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then
            If x >= ctl.Left And x <= ctl.Left + ctl.Width And y >= ctl.Top And y <= ctl.Top + ctl.Height Then
                ctl.BackColor = RGB(0, 0, 0)
                Set 寻鱼 = ctl
            Else
                ctl.BackColor = RGB(255, 255, 255)
            End If
        End If
    End If
Next ctl
寻鱼_Exit:
    Exit Function
寻鱼_Err:
    Resume 寻鱼_Exit
End Function

Public Sub 起钩(frm As Form, 钓钩 As Control, x As Single, y As Single)
Dim ctl As Control
On Error GoTo 钓钩_Err
Set ctl = 寻鱼(frm, x, y)
ctl.Value = Nz(钓钩.Value)
ctl.SetFocus
ctl.BackColor = RGB(255, 255, 255)
钓钩.Move 0, 0
钓钩.Value = Null
钓钩.Visible = False

钓钩_Exit:
    Exit Sub
钓钩_Err:
    Resume 钓钩_Exit
End Sub

wanshan

非常感谢分享，学习！
既不需要回复才能看到，也不加密！谢谢！
再赞文采……

zxklzxm1983

  又是板凳

围观仰视楼主

chaojianan

楼主不写小说，屈才也。

tmtony

程序上乘, 文采更佳!

ACMAIN_CHM

强
很强
非常强

tanhong

不错的作品，收藏学习。

aslxt

不错的作品，收藏学习

todaynew

谢谢首长和同志们支持与鼓励