滚轴特效代码（上古卷轴效果代码）

今天给各位分享滚轴特效代码的知识，其中也会对上古卷轴效果代码进行解释，如果能碰巧解决你现在面临的问题，别忘了关注本站，现在开始吧！

本文目录一览：

• 1、delphi中怎么在DBgrid中实现鼠标滚轮效果
• 2、vb鼠标滚轮问题
• 3、html 鼠标滚轴滚动 图片跟着上下滚动

delphi中怎么在DBgrid中实现鼠标滚轮效果

在新版本 delphi 中，DBGrid 组件自带有响应鼠标滚动事件：

如果当前 DBGrid 组件没有鼠标滚动消息事件，可以通过 Application 进行自定义消息实现，以下是示例代码：

procedure ApplicationEvents1Message(var Msg: tagMSG;var Handled: Boolean);

procedure  TForm1.ApplicationEvents1Message(var  Msg:  tagMSG;var  Handled:  Boolean);

begin

 if  (DBGrid2.Focused)  And  (Msg.message  =  WM_MOUSEWHEEL)  then

       begin

           if  Msg.wParam    0  then

               SendMessage(DBGrid2.Handle,  WM_KEYDOWN,  VK_UP,  0)

           else

               SendMessage(DBGrid2.Handle,  WM_KEYDOWN,  VK_DOWN,  0);

           Handled  :=  True;

       end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

  Application.OnMessage:=ApplicationEvents1Message; // 截获鼠标滚动事件

end;

vb鼠标滚轮问题

标滚轮能给系统的使用带来很大便利，如使用滚轮移动选择这项，但在VB中的一些常用控件（如：文件框、列表框等）中没有提供鼠标滚轮滚动选择的效果。现将自己写的鼠标滚轮特效实现代码分享给大家： 本例子就是一个对Win32 API的调用，达到对ListBox、PictureBox等的鼠标滚轮控制。首先，申明windows API调用，将其放在模块modWheel中，以供用户控件使用。原理很简单，通过鼠标滚轮可以对如下白色的横线进行控制，效果图如下：相关代码如下： 鼠标滚轮处理模块(modWheel)

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _

(pDest As Any, pSource As Any, ByVal ByteLen As Long)

Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _

(ByVal hWnd As Long, ByVal nIndex As Long) As Long

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _

(ByVal hWnd As Long, ByVal nIndex As Long, _

ByVal dwNewLong As Long) As Long

Public Const GWL_WNDPROC = (-4)

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _

(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, _

ByVal Msg As Long, ByVal wParam As Long, _

ByVal lParam As Long) As Long

Declare Function SetProp Lib "user32" Alias "SetPropA" _

(ByVal hWnd As Long, ByVal lpString As String, _

ByVal hData As Long) As Long

Declare Function GetProp Lib "user32" Alias "GetPropA" _

(ByVal hWnd As Long, ByVal lpString As String) As Long

Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _

(ByVal hWnd As Long, ByVal lpString As String) As Long

Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long

Public Const WM_MOUSEWHEEL = H20A

Public Const WM_MOUSELAST = H20A

Public Const WHEEL_DELTA = 120

Public Function HIWORD(LongIn As Long) As Integer

HIWORD = (LongIn And HFFFF0000) \ H10000

End Function

Public Function MWheelProc(ByVal hWnd As Long, _

ByVal wMsg As Long, ByVal wParam As Long, _

ByVal lParam As Long) As Long

Dim OldProc As Long

Dim CtlWnd As Long

Dim CtlPtr As Long

Dim IntObj As Object

Dim MWObject As MWheel

CtlWnd = GetProp(hWnd, "WheelWnd")

CtlPtr = GetProp(CtlWnd, "WheelPtr")

OldProc = GetProp(CtlWnd, "OldWheelProc")

If wMsg = WM_MOUSEWHEEL Then

CopyMemory IntObj, CtlPtr, 4

Set MWObject = IntObj

MWObject.WndProc hWnd, wMsg, wParam, lParam

Set MWObject = Nothing

CopyMemory IntObj, 0, 4

Exit Function

End If

MWheelProc = CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)

End Function

Public Sub Subclass(MWCtl As MWheel, ParentWnd As Long)

If GetProp(MWCtl.hWnd, "OldWheelProc") 0 Then

Exit Sub

End If

SetProp MWCtl.hWnd, "OldWheelProc", _

GetWindowLong(ParentWnd, GWL_WNDPROC)

SetProp MWCtl.hWnd, "WheelPtr", ObjPtr(MWCtl)

SetProp ParentWnd, "WheelWnd", MWCtl.hWnd

SetWindowLong ParentWnd, GWL_WNDPROC, AddressOf MWheelProc

End Sub

Public Sub UnSubclass(MWCtl As MWheel, ParentWnd As Long)

Dim OldProc As Long

OldProc = GetProp(MWCtl.hWnd, "OldWheelProc")

If OldProc = 0 Then Exit Sub

SetWindowLong ParentWnd, GWL_WNDPROC, OldProc

RemoveProp ParentWnd, "WheelWnd"

RemoveProp MWCtl.hWnd, "WheelPtr"

RemoveProp MWCtl.hWnd, "OldWheelProc"

End Sub

然后，定义用户控件MWheel，实现对相关控件鼠标滚轮事件的处理。用户控件（MWheel)代码

Option Explicit

Dim m_CapWnd As Long

Dim m_Subclassed As Boolean

Event WheelScroll(Shift As Integer, zDelta As Integer, _

X As Single, Y As Single)

Private Sub UserControl_Resize()

Size 32 * Screen.TwipsPerPixelX, 32 * Screen.TwipsPerPixelY

End Sub

Public Sub DisableWheel()

If m_CapWnd = 0 Then Exit Sub

If m_Subclassed = False Then Exit Sub

UnSubclass Me, m_CapWnd

m_Subclassed = False

End Sub

Public Sub EnableWheel()

If m_CapWnd = 0 Then Exit Sub

m_Subclassed = True

Subclass Me, m_CapWnd

End Sub

Friend Property Get hWnd() As Long

hWnd = UserControl.hWnd

End Property

Public Property Get hWndCapture() As Long

hWndCapture = m_CapWnd

End Property

Public Property Let hWndCapture(ByVal vNewValue As Long)

m_CapWnd = vNewValue

End Property

Friend Sub WndProc(ByVal hWnd As Long, _

ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)

Dim wShift As Integer

Dim wzDelta As Integer

Dim wX As Single, wY As Single

wzDelta = HIWORD(wParam)

wY = HIWORD(lParam)

RaiseEvent WheelScroll(wShift, wzDelta, wX, wY)

End Sub最后，就可以将定义的用户控件用在vb窗体编程中，实现对鼠标滚轮事件的监听和处理，测试主窗体如下：Option Explicit

Dim KAs As Long

Dim KA1 As Long

Dim KA2 As Long

Private Sub Picture1_Click()

MWheel1.hWndCapture = Picture1.hWnd

MWheel1.EnableWheel

End Sub

Private Sub List1_Click()

MWheel2.hWndCapture = List1.hWnd

MWheel2.EnableWheel

KA1 = List1.ListCount

End Sub

Private Sub File1_Click()

MWheel3.hWndCapture = File1.hWnd

MWheel3.EnableWheel

KA1 = File1.ListCount

End Sub

Private Sub MWheel2_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)

If KAs 0 Then

If zDelta = 120 Then

KAs = KAs - 1

List1.ListIndex = KAs

End If

End If

If KAs KA1 - 1 Then

If zDelta = -120 Then

KAs = KAs + 1

List1.ListIndex = KAs

End If

End If

End Sub

Private Sub MWheel1_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)

If zDelta = 120 Then

KA2 = KA2 - 5

Line1.Y1 = KA2

Line1.Y2 = KA2

End If

If zDelta = -120 Then

KA2 = KA2 + 5

Line1.Y1 = KA2

Line1.Y2 = KA2

End If

End Sub

Private Sub MWheel3_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)

If KAs 0 Then

If zDelta = 120 Then

KAs = KAs - 1

File1.ListIndex = KAs

End If

End If

If KAs KA1 - 1 Then

If zDelta = -120 Then

KAs = KAs + 1

File1.ListIndex = KAs

End If

End If

End Sub/SPAN

html 鼠标滚轴滚动 图片跟着上下滚动

!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" ""

html xmlns=""

head

meta http-equiv="Content-Type" content="text/html; charset=gb2312" /

title无标题文档 /title

script language="javascript"

var Atop = 0;

function inix(){

Atop = findPos(document.getElementByIdx("Layer1"))[1];

}

function move(){

document.getElementByIdx("Layer1").style.pixelTop = Atop + document.documentElement.scrollTop;

}

function findPos(obj){

var curleft = curtop = 0;

if (obj.offsetParent) {

do {

curleft += obj.offsetLeft;

curtop += obj.offsetTop;

}

while (obj = obj.offsetParent);

}

return [curleft, curtop];

}

window.onscroll = move;

/script

style type="text/css"

!-- #Layer1 {

position: absolute;

left: 48px;

top: 49px;

width: 82px;

height: 82px;

z-index: 1;

}

--

/style

/head

body onload="inix();"

div id="Layer1"

img src="images/float_advclose1.gif" width="80" height="80" /

/div

table width="200" border="1" align="center"

tr

td

img src="images/xiaojie1.jpg" width="768" height="1113" /

/td

/tr

/table

/body

/html

解释：

1 代码：window.onscroll = move;

页面滚动window的onscroll调用move方法。

2 函数 function findPos(obj)

获得一个元素在页面上的绝对位置。要先获得这个元素与父元素的相对位置再获得父元素的父元素的相对位置, 一直循环到根元素，然后把相对位置相加。

关于滚轴特效代码和上古卷轴效果代码的介绍到此就结束了，不知道你从中找到你需要的信息了吗 ？如果你还想了解更多这方面的信息，记得收藏关注本站。