VB Quicktakes - Smiling Round Window

For this quicktake there are several interesting things going on: 1. A round window is created 2. That window is set to be displayed on as the top window on the screen. 3. The SysInfo control is used to gather info about the screen. 4. This program is pretty fun. Just what does this example do? Well it creates a round window that looks like a smilie face that bounces of the screen sides and top and on the bottom off of the task bar. In order to end the program you need to shoot the smilie face by clicking on him 10 times. Included after code are the list of controls needed and the properties that they should have.

Option Explicit

Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function SetWindowPos Lib "user32" _
         (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
          ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1

Private Sub Form_Load() '***************************Code to Create Round Window*************************************** Dim hr As Long, dl As Long Dim lngWidth As Long, lngHeight As Long lngWidth = Me.Width / Screen.TwipsPerPixelX lngHeight = Me.Height / Screen.TwipsPerPixelY hr& = CreateEllipticRgn(0, 0, lngWidth, lngHeight) dl& = SetWindowRgn(Me.hwnd, hr, True) '*********************************************************************************************************** PutWindowOnTop End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.BackColor = vbRed shpBlock.BorderColor = vbRed shpBlock.FillColor = vbRed End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Static i As Integer Me.BackColor = vbYellow shpBlock.BorderColor = vbYellow shpBlock.FillColor = vbYellow i = i + 1 If i > 10 Then StartEnd End If End Sub
'This timer is used to move the smilie window around bouncing it off the sides and top of the screen on the bottom it bounces off of the TaskBar. Private Sub Timer1_Timer() Dim xRate As Long, yRate As Long Static xdir As Integer Static ydir As Integer xRate = 55 yRate = 55 If xdir = 0 Then xdir = 1 ydir = 1 End If Me.Move Me.Left + xRate * xdir, Me.Top + yRate * ydir If Me.Left - xRate <= syiHeight.WorkAreaLeft Then xdir = 1 End If If Me.Left + 55 + Me.Width > syiHeight.WorkAreaWidth + syiHeight.WorkAreaLeft Then xdir = -1 End If If Me.Top - yRate <= syiHeight.WorkAreaTop Then ydir = 1 End If If Me.Top + yRate + Me.Height > syiHeight.WorkAreaHeight + syiHeight.WorkAreaTop Then ydir = -1 End If End Sub
Public Function PutWindowOnTop() Dim lngWindowPosition As Long lngWindowPosition = SetWindowPos(Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE) End Function
Private Sub StartEnd() Timer1.Interval = 0 Timer2.Interval = 25 shpBlock.Visible = False End Sub
'This timer just creates an ending sequence Private Sub Timer2_Timer() Static i As Integer If Me.BackColor = vbRed Then Me.BackColor = vbYellow Else Me.BackColor = vbRed End If i = i + 1 If i = 20 Then Unload Me End If End Sub

Controls & Properties

frmRound height =1785,width =1890Backcolor=&H0000FFFF&Borderstyle=0MousePointer=2 (cross)
Shape1(0) top=360,left=600 height =495,width =135 Shape =2 (oval) Fillstyle = 0 (solid)BorderColor and Fillcolor=&H00000000&
Shape1(1) top=360,left=1200 height =495,width =135 Shape =2 (oval) Fillstyle = 0 (solid)BorderColor and Fillcolor=&H00000000&
Shape2 top=1080,left=360 height =375,width =1215 Shape =2 (oval) Fillstyle = 1 (trans)BorderColor =&H00000000&
shpBlock* top=840,left=240 height =495,width =1455 Shape =0 (rect) Fillstyle = 0 (solid)BorderColor and FillColor=&H0000FFFF&
Timer1 interval=5
Timer2 interval=0
* Make sure shpBlock is above shape2 in the zorder.
**In order to get the sysInfo control go toolbox right click and select components, from the list that pops up check off Microsoft SysInfo Control and click okay.
About this page: