Cursor follower [Re-opened]

**Boing** · Jul 12th, 2009, 06:32 AM

I am working on a small vb project in which there is a small transparent gif having transparent background which will be attached to one corner of screen and other part of image will be attached to to cursor. The image is like fancy chain whose one end is fixed to corner an other is attached to cursor and moves with it. but i don't want to stretch the image with the movement pf cursor, my image is diagnol chain of high resolution...
can any one provide me code for this app.

**Garrcomm** · Jul 12th, 2009, 06:59 AM

So you only need to know the cursors location on the screen?

Code:

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI
        X As Long
        Y As Long
End Type

Sub Main()
        Dim p As POINTAPI
        GetCursorPos p
        MsgBox p.X & "x" & p.Y
End Sub

**technorobbo** · Jul 12th, 2009, 10:46 AM

Originally Posted by Boing

The image is like fancy chain whose one end is fixed to corner an other is attached to cursor and moves with it. but i don't want to stretch the image with the movement of cursor, my image is diagnol chain of high resolution...

If you don't want it to stretch what do you want it to do at different distance from the corner.

Pull out like a measuring tape?
Sag and always be the same legnth?
Do you have a gravity algorithm?
Is it a Link Chain? Oval Links? Round Links?
Is the graphic for the entire screen or just the form?

Can you post a graphical example (jpg's or gif). Doesn't have to be animated but a storyboard would help showing fully extended and close to corner.

**technorobbo** · Jul 12th, 2009, 08:03 PM

Is this what you mean? The attached code creates a center of gravity effect giving the chain a sense of weight.

http://www.vbforums.com/attachment.p...6&d=1247831982

**Boing** · Jul 13th, 2009, 08:51 AM

thank you mr.robo but how do we remove the bending of chain? and can i apply transparent back to it?

**Milk** · Jul 13th, 2009, 09:53 AM

Boing, are you able to to make a sketch of what you want as Technorobbo asks. Perhaps post the chain image you have as well.

I'm having some difficulty picturing an image that does not stretch and does not bend yet links the corner of the screen to the cursor. Is it like Technorobbo's tape measure description?

Do you want this image to rotate?

**technorobbo** · Jul 13th, 2009, 09:54 PM

Originally Posted by Boing

thank you mr.robo but how do we remove the bending of chain? and can i apply transparent back to it?

Mr. Robbo? Mr. Robbo's my father - you can call me techno. All Joking aside, I , like Milk am also having trouble without some kind of pre-vis (previsualization).

But going along with your request, I removed the vector intersection and bezier math and put in a simple scaling routine instead. doesn't look as fancy but maybe that's what you wanted.

By "transparent back" I assume you meant a transparent GIF. I put in a simple routine to transform a transparent GIF to a bitmap with a keycolor in a picturebox. Works just as well but GIF's limit the number colors to 256.

Post Edit

One more thing- as Milk pointed out, you may need to rotate your link to create a better illusion. I cheated, I used a round object. Is your object a round link?

**technorobbo** · Jul 17th, 2009, 07:07 AM

If your still interested check out this codebank entry I wrote:
http://www.vbforums.com/showthread.p...73#post3557773

I took the first example - added the pythagorean theorem to ensure constant chain length, and from many years of PID programming - I added a proportinal calculation to simulate inertia in the chain.

A very convincing simulation!

**Boing** · Aug 20th, 2009, 02:19 AM

hey techno sorry for late reply, but when using my own image i got some problems- its not getting displayed, i dont know why...but your image working good
what might be the reason?

here i have attached the image that i wanted-:

**technorobbo** · Aug 20th, 2009, 05:57 AM

he following changes apply to the code in the codeback:
http://www.vbforums.com/showthread.p...73#post3557773

The differences in the 3 images have to be accounted for:

1. The new image uses a white background while the old one uses red for transparency - I swicthed colors and attached below.

2. LoadImage requires a bitmap, cursor or Icon - I converted it to bitmap. The is can also be compensated for by using a stdpicture with loadpicture.

3. The New image is 20X17 the old is 19X19 so the following changes should be made to the code.

From:

Code:

handle = LoadImage(App.hInstance, App.Path & "\pearl.bmp", IMAGE_BITMAP, 19, 19, LR_CREATEDIBSECTION Or LR_LOADFROMFILE)

To:

Code:

handle = LoadImage(App.hInstance, App.Path & "\test.bmp", IMAGE_BITMAP, 20, 17, LR_CREATEDIBSECTION Or LR_LOADFROMFILE)

From:

Code:

TransparentBlt dbhdc, tempx - 9, _
            tempy - 9, 19, 19, MyHdc, 0, 0, 19, 19, vbRed

To:

Code:

TransparentBlt dbhdc, tempx - 10, _
            tempy - 8, 20, 17, MyHdc, 0, 0, 20, 17, vbRed

you also might want to define the for next loop like this:

Code:

For tsq = 0 To 1 Step 0.005

for a tighter chain.

Are your looking for the links to rotate then or are you going for the flat effect? If we want the links to rotate the we would have to employ a plgblt with a mask.

**Boing** · Aug 20th, 2009, 10:55 AM

Thanks Techno its working now, but when im putting tightness to 0.001 or less than that the followers seems to be laging behind, what might be the reason for this ? and what do i have to do for putting anchor for my rope in right-bottom corner of screen instead of left-top?

**technorobbo** · Aug 20th, 2009, 11:55 AM

The more tightness the more calculations. -
I'll post right bottom screen changes when I get home.

**technorobbo** · Aug 20th, 2009, 08:12 PM

Here ya go - from lower right with test.bmp. Escape to exit

Code:

Option Explicit
Private Const IMAGE_ICON As Long = 1
Private Const IMAGE_CURSOR As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LR_CREATEDIBSECTION As Long = &H2000

Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0

Private Type BITMAPINFOHEADER '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type
Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
Private Type BITMAPINFO

        bmiheader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT)
Private Declare Sub ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long)

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean

Dim handle As Long, MyHdc As Long
Dim stdhdc As Long, dbuf As Long, dbhdc As Long
Dim bmi As BITMAPINFO, BgBuffer As Long, bmiheader As BITMAPINFOHEADER
Dim mpx As Single, mpy As Single
Dim delayX As Single
Dim delayY As Single
Dim swing As Single
Dim pi As Single


Private Sub Form_KeyPress(KeyAscii As Integer)
Unload Me
End Sub

Private Sub Form_Load()
Dim i As Integer, x As Long
Dim client As RECT
Dim upperleft As POINTAPI

pi = Atn(1) * 4
Me.Show
Me.AutoRedraw = True

GetClientRect Me.hWnd, client
upperleft.x = client.left
upperleft.y = client.top
ClientToScreen Me.hWnd, upperleft
OffsetRect client, upperleft.x, upperleft.y
ClipCursor client

delayX = 0: delayY = Me.ScaleHeight

dbhdc = CreateCompatibleDC(0)
bmi.bmiheader.biSize = Len(bmiheader)
bmi.bmiheader.biWidth = Me.ScaleWidth
bmi.bmiheader.biHeight = Me.ScaleHeight
bmi.bmiheader.biPlanes = 1
bmi.bmiheader.biBitCount = 32
bmi.bmiheader.biCompression = BI_RGB
bmi.bmiheader.biSizeImage = bmi.bmiheader.biWidth * bmi.bmiheader.biHeight * 4
dbuf = CreateDIBSection(dbhdc, bmi, DIB_RGB_COLORS, 0&, 0&, 0&)
SelectObject dbhdc, dbuf
Me.ScaleMode = vbPixels
Me.AutoRedraw = False
Me.WindowState = 2
handle = LoadImage(App.hInstance, App.Path & "\test.bmp", IMAGE_BITMAP, 20, 17, LR_CREATEDIBSECTION Or LR_LOADFROMFILE)
MyHdc = CreateCompatibleDC(0)
SelectObject MyHdc, handle
Timer1.Interval = 5
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
mpx = x + 0.01: mpy = y + 0.01
End Sub
Private Sub Form_Unload(Cancel As Integer)
ClipCursor 0&
DeleteDC MyHdc
DeleteDC stdhdc
DeleteDC dbhdc
DeleteObject handle
End Sub

Private Sub Timer1_Timer()
Dim tsq As Single, ua As Single, x As Single, y As Single
Dim x1 As Single, x2 As Single, y1 As Single, y2 As Single
Dim x3 As Single, x4 As Single, y3 As Single, y4 As Single
Dim tempx1 As Single
Dim tempy1 As Single
Dim tempx2 As Single
Dim tempy2 As Single
Dim tempx As Single
Dim tempy As Single
Dim point As POINTAPI
Dim hype As Double
Static lastx As Single
Static lasty As Single
Static xDiff As Single
Static YDiff As Single
hype = Sqr(Me.ScaleHeight ^ 2 + Me.ScaleWidth ^ 2)

'gravity
With Me
    x1 = .ScaleWidth: y1 = .ScaleHeight: x2 = 0: y2 = 0
    x3 = mpx: y3 = .ScaleHeight: x4 = mpx: y4 = mpy
    ua = ((x4 - x3) * (y1 - y3) - (y4 - y3) * (x1 - x3)) / ((y4 - y3) * (x2 - x1) - (x4 - x3) * (y2 - y1))
    x = x1 + ua * (x2 - x1)
    y = Sqr(hype ^ 2 - x ^ 2) * 0.6
End With
'inertia
lastx = lastx * 0.8 + (x - delayX) * 0.2
delayX = lastx + delayX
lasty = lasty * 0.8 + (y - delayY) * 0.2
delayY = lasty + delayY

Me.AutoRedraw = True
BitBlt dbhdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, Me.hdc, 0, 0, vbSrcCopy
Me.AutoRedraw = False
'MoveToEx dbhdc, tempx, tempy, point
For tsq = 0 To 1 Step 0.005

    tempx1 = (x1 * (1 - tsq)) + (delayX * tsq)
    tempy1 = (y1 * (1 - tsq)) + (delayY * tsq)
    tempx2 = (delayX * (1 - tsq)) + (x4 * tsq)
    tempy2 = (delayY * (1 - tsq)) + (y4 * tsq)
    tempx = (tempx1 * (1 - tsq)) + (tempx2 * tsq)
    tempy = (tempy1 * (1 - tsq)) + (tempy2 * tsq)
    TransparentBlt dbhdc, tempx - 10, _
            tempy - 8, 20, 17, MyHdc, 0, 0, 20, 17, vbRed
'    LineTo dbhdc, tempx, tempy
Next
BitBlt Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, dbhdc, 0, 0, vbSrcCopy
End Sub

**Boing** · Aug 21st, 2009, 01:17 AM

Thanks again Techno this code is working good like a real game, but i wanna remove that bending from below again, i want it to be straight.....but i really like that effect in middle of rope which makes it go right an left a bit (like a spring or spongy effect) whenever the mouse pointer is moved. how to make it like that?
Thanks again

**technorobbo** · Aug 21st, 2009, 09:37 AM

It's just amatter of movig the gravity point between the start and end points - I'll post the change when I get home

**technorobbo** · Aug 21st, 2009, 09:09 PM

Ok - here ya go. Inertia with no gravity - kinda like a tether in space:

Code:

Option Explicit
Private Const IMAGE_ICON As Long = 1
Private Const IMAGE_CURSOR As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LR_CREATEDIBSECTION As Long = &H2000

Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0

Private Type BITMAPINFOHEADER '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type
Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
Private Type BITMAPINFO

        bmiheader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT)
Private Declare Sub ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long)

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean

Dim handle As Long, MyHdc As Long
Dim stdhdc As Long, dbuf As Long, dbhdc As Long
Dim bmi As BITMAPINFO, BgBuffer As Long, bmiheader As BITMAPINFOHEADER
Dim mpx As Single, mpy As Single
Dim delayX As Single
Dim delayY As Single
Dim swing As Single
Dim pi As Single


Private Sub Form_KeyPress(KeyAscii As Integer)
Unload Me
End Sub

Private Sub Form_Load()
Dim i As Integer, x As Long
Dim client As RECT
Dim upperleft As POINTAPI

pi = Atn(1) * 4
Me.Show
Me.AutoRedraw = True

GetClientRect Me.hWnd, client
upperleft.x = client.left
upperleft.y = client.top
ClientToScreen Me.hWnd, upperleft
OffsetRect client, upperleft.x, upperleft.y
ClipCursor client

delayX = 0: delayY = Me.ScaleHeight

dbhdc = CreateCompatibleDC(0)
bmi.bmiheader.biSize = Len(bmiheader)
bmi.bmiheader.biWidth = Me.ScaleWidth
bmi.bmiheader.biHeight = Me.ScaleHeight
bmi.bmiheader.biPlanes = 1
bmi.bmiheader.biBitCount = 32
bmi.bmiheader.biCompression = BI_RGB
bmi.bmiheader.biSizeImage = bmi.bmiheader.biWidth * bmi.bmiheader.biHeight * 4
dbuf = CreateDIBSection(dbhdc, bmi, DIB_RGB_COLORS, 0&, 0&, 0&)
SelectObject dbhdc, dbuf
Me.ScaleMode = vbPixels
Me.AutoRedraw = False
Me.WindowState = 2
handle = LoadImage(App.hInstance, App.Path & "\test.bmp", IMAGE_BITMAP, 20, 17, LR_CREATEDIBSECTION Or LR_LOADFROMFILE)
MyHdc = CreateCompatibleDC(0)
SelectObject MyHdc, handle
Timer1.Interval = 5
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
mpx = x + 0.01: mpy = y + 0.01
End Sub
Private Sub Form_Unload(Cancel As Integer)
ClipCursor 0&
DeleteDC MyHdc
DeleteDC stdhdc
DeleteDC dbhdc
DeleteObject handle
End Sub

Private Sub Timer1_Timer()
Dim tsq As Single, ua As Single, x As Single, y As Single
Dim x1 As Single, x2 As Single, y1 As Single, y2 As Single
Dim x3 As Single, x4 As Single, y3 As Single, y4 As Single
Dim tempx1 As Single
Dim tempy1 As Single
Dim tempx2 As Single
Dim tempy2 As Single
Dim tempx As Single
Dim tempy As Single
Dim point As POINTAPI
Dim hype As Double
Static lastx As Single
Static lasty As Single
Static xDiff As Single
Static YDiff As Single
hype = Sqr(Me.ScaleHeight ^ 2 + Me.ScaleWidth ^ 2)

'gravity
With Me
    x1 = .ScaleWidth: y1 = .ScaleHeight
    x4 = mpx: y4 = mpy
    x = (x1 + x4) / 2
    y = (y4 + y1) / 2

End With
'inertia
lastx = lastx * 0.8 + (x - delayX) * 0.2
delayX = lastx + delayX
lasty = lasty * 0.8 + (y - delayY) * 0.2
delayY = lasty + delayY

Me.AutoRedraw = True
BitBlt dbhdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, Me.hdc, 0, 0, vbSrcCopy
Me.AutoRedraw = False
'MoveToEx dbhdc, tempx, tempy, point
For tsq = 0 To 1 Step 0.01

    tempx1 = (x1 * (1 - tsq)) + (delayX * tsq)
    tempy1 = (y1 * (1 - tsq)) + (delayY * tsq)
    tempx2 = (delayX * (1 - tsq)) + (x4 * tsq)
    tempy2 = (delayY * (1 - tsq)) + (y4 * tsq)
    tempx = (tempx1 * (1 - tsq)) + (tempx2 * tsq)
    tempy = (tempy1 * (1 - tsq)) + (tempy2 * tsq)
    TransparentBlt dbhdc, tempx - 10, _
            tempy - 8, 20, 17, MyHdc, 0, 0, 20, 17, vbRed
'    LineTo dbhdc, tempx, tempy
Next
BitBlt Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, dbhdc, 0, 0, vbSrcCopy
End Sub

**Boing** · Aug 22nd, 2009, 06:40 AM

a million thanks, it looks pretty good
You are really good

Edit: but sorry to bug you again can you tell me how to get my background transparent instead of desert that pic, so that i can see my desktop....i have tried removing back pic but it seems that it only works with that pic.
i wanaa make it like screen mate game...

**technorobbo** · Aug 22nd, 2009, 11:34 AM

Sure, but you realize that no one can click on desktop icons and you'll confuse them?

Ok that being said - this will slow down the chain movement since windows is doing the transparent backgroungd thing.

You'll need to make your form with a borderstyle of zero! Add 1 picture control - in this example it's called picture1. Remember to hit any key to exit.

Code:

Option Explicit
Private Const IMAGE_ICON As Long = 1
Private Const IMAGE_CURSOR As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LR_CREATEDIBSECTION As Long = &H2000

Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0

Private Type BITMAPINFOHEADER '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type
Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
Private Type BITMAPINFO

        bmiheader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)
Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long)

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long


'transparent code API
Const LWA_COLORKEY = &H1
Const LWA_ALPHA = &H2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
Private Declare Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal crKey As Long, _
    ByVal bAlpha As Byte, _
    ByVal dwFlags As Long) As Long
'===================================


Dim handle As Long, MyHdc As Long
Dim stdhdc As Long, dbuf As Long, dbhdc As Long
Dim bmi As BITMAPINFO, BgBuffer As Long, bmiheader As BITMAPINFOHEADER
Dim mpx As Single, mpy As Single
Dim delayX As Single
Dim delayY As Single
Dim swing As Single
Dim pi As Single


Private Sub Form_KeyPress(KeyAscii As Integer)
Unload Me
End Sub

Private Sub Form_Load()
Dim i As Integer, x As Long
Dim client As RECT
Dim upperleft As POINTAPI
Me.Caption = ""
pi = Atn(1) * 4
Me.WindowState = vbMaximized
Me.ScaleMode = vbPixels
Me.Show
With Picture1
    .ScaleMode = vbPixels
    .BorderStyle = 0
    .Picture = LoadPicture()
    .top = 0
    .left = 0
    .Width = Me.ScaleWidth
    .Height = Me.ScaleHeight
    .Visible = False
    .AutoRedraw = True
End With



delayX = 0: delayY = Me.ScaleHeight

dbhdc = CreateCompatibleDC(0)
bmi.bmiheader.biSize = Len(bmiheader)
bmi.bmiheader.biWidth = Me.ScaleWidth
bmi.bmiheader.biHeight = Me.ScaleHeight
bmi.bmiheader.biPlanes = 1
bmi.bmiheader.biBitCount = 32
bmi.bmiheader.biCompression = BI_RGB
bmi.bmiheader.biSizeImage = bmi.bmiheader.biWidth * bmi.bmiheader.biHeight * 4
dbuf = CreateDIBSection(dbhdc, bmi, DIB_RGB_COLORS, 0&, 0&, 0&)
SelectObject dbhdc, dbuf
Me.ScaleMode = vbPixels
Me.AutoRedraw = False
Me.WindowState = 2
handle = LoadImage(App.hInstance, App.Path & "\test.bmp", IMAGE_BITMAP, 20, 17, LR_CREATEDIBSECTION Or LR_LOADFROMFILE)
MyHdc = CreateCompatibleDC(0)
SelectObject MyHdc, handle


'make background disappear
Dim k As Long
Me.BackColor = RGB(0, 0, 255)
k = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
k = k Or WS_EX_LAYERED
SetWindowLong Me.hwnd, GWL_EXSTYLE, k
SetLayeredWindowAttributes Me.hwnd, Me.BackColor, 0, LWA_COLORKEY
DoEvents

Picture1.AutoRedraw = True
Picture1.Visible = True
BitBlt Picture1.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, GetDC(0), 0, 0, vbSrcCopy
Picture1.AutoRedraw = False
'===========================
Timer1.Interval = 15
End Sub

Private Sub Picture1_KeyPress(KeyAscii As Integer)
Unload Me
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
mpx = x + 0.01: mpy = y + 0.01
End Sub
Private Sub Form_Unload(Cancel As Integer)
ClipCursor 0&
DeleteDC MyHdc
DeleteDC stdhdc
DeleteDC dbhdc
DeleteObject handle
End Sub

Private Sub Timer1_Timer()
Dim tsq As Single, ua As Single, x As Single, y As Single
Dim x1 As Single, x2 As Single, y1 As Single, y2 As Single
Dim x3 As Single, x4 As Single, y3 As Single, y4 As Single
Dim tempx1 As Single
Dim tempy1 As Single
Dim tempx2 As Single
Dim tempy2 As Single
Dim tempx As Single
Dim tempy As Single
Dim point As POINTAPI
Static lastx As Single
Static lasty As Single
Static xDiff As Single
Static YDiff As Single

'gravity
With Picture1
    x1 = .ScaleWidth: y1 = .ScaleHeight
    x4 = mpx: y4 = mpy
    x = (x1 + x4) / 2
    y = (y4 + y1) / 2

End With
'inertia
lastx = lastx * 0.8 + (x - delayX) * 0.2
delayX = lastx + delayX
lasty = lasty * 0.8 + (y - delayY) * 0.2
delayY = lasty + delayY


BitBlt dbhdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, GetDC(0), 0, 0, vbSrcCopy

'MoveToEx dbhdc, tempx, tempy, point
For tsq = 0 To 1 Step 0.01

    tempx1 = (x1 * (1 - tsq)) + (delayX * tsq)
    tempy1 = (y1 * (1 - tsq)) + (delayY * tsq)
    tempx2 = (delayX * (1 - tsq)) + (x4 * tsq)
    tempy2 = (delayY * (1 - tsq)) + (y4 * tsq)
    tempx = (tempx1 * (1 - tsq)) + (tempx2 * tsq)
    tempy = (tempy1 * (1 - tsq)) + (tempy2 * tsq)
    TransparentBlt dbhdc, tempx - 10, _
            tempy - 8, 20, 17, MyHdc, 0, 0, 20, 17, vbRed
'    LineTo dbhdc, tempx, tempy
Next
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, dbhdc, 0, 0, vbSrcCopy
DoEvents
End Sub

**Boing** · Aug 23rd, 2009, 05:22 AM

Thanks techno, love you

**Boing** · Mar 31st, 2010, 09:50 AM

Sorry For opening this again people, but im experiencing some lag in follower and as i was updating my older version, i want to remove some lag in follower, my tightness is

Code:

For tsq = 0 To 1 Step 0.001

so is there anything that we can do to make this beter, without lag by doing some calculations etc...

Thank you
BOing

Thread: Cursor follower [Re-opened]

Thread Tools

Display

Cursor follower [Re-opened]

Re: Cursor follower

Re: Cursor follower

Re: Cursor follower

Re: Cursor follower

Re: Cursor follower

Re: Cursor follower

Re: Cursor follower

Re: Cursor follower

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Re: Cursor follower [Re-opened]

Posting Permissions