Printable View
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.
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
If you don't want it to stretch what do you want it to do at different distance from the corner.Quote:
Originally Posted by Boing
- 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.
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
thank you mr.robo but how do we remove the bending of chain? and can i apply transparent back to it?
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?
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).Quote:
Originally Posted by Boing
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?
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!
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-:
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:
To:Code:handle = LoadImage(App.hInstance, App.Path & "\pearl.bmp", IMAGE_BITMAP, 19, 19, LR_CREATEDIBSECTION Or LR_LOADFROMFILE)
From:Code:handle = LoadImage(App.hInstance, App.Path & "\test.bmp", IMAGE_BITMAP, 20, 17, LR_CREATEDIBSECTION Or LR_LOADFROMFILE)
To:Code:TransparentBlt dbhdc, tempx - 9, _
tempy - 9, 19, 19, MyHdc, 0, 0, 19, 19, vbRed
you also might want to define the for next loop like this:Code:TransparentBlt dbhdc, tempx - 10, _
tempy - 8, 20, 17, MyHdc, 0, 0, 20, 17, vbRed
for a tighter chain.Code:For tsq = 0 To 1 Step 0.005
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.
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?
The more tightness the more calculations. -
I'll post right bottom screen changes when I get home.
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
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
It's just amatter of movig the gravity point between the start and end points - I'll post the change when I get home
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
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...
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
Thanks techno, love you
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
so is there anything that we can do to make this beter, without lag by doing some calculations etc...Code:For tsq = 0 To 1 Step 0.001
Thank you
BOing