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 HWND_TOPMOST = -1
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
syiHeight**
* 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: