Change background image
  1. What's up? I see you're viewing as a Guest. How about registering, it only takes like 2 minutes. This will enable you to do more on our forum and stay updated.

GUI Effects Module [VB6]

Discussion in 'Developer General' started by 3nvisi0n, Jun 21, 2011.

Thread Status:
This thread is more than 180 days old.
  1. 3nvisi0n

    3nvisi0n The R3v0lu710n Super-Mod

    Hey,

    I was going through my harddrive and came across this old file of mine. I wrote it for Visual Basic 6 to handle various GUI effects, like Fades, Flashes(like how MSN flashes when you get a message) Transparency, True custom shaped forms, and some others I have probably forgotten. It is decently documented I'm not including any example usages just the code for your inclusion...it is a module for vb6. At the least this shows how hard it used to be to do the cool stuff, the Visual Basics since 6 make it much easier no need for all the API calls...for some of it at least

    Code:
    Option Explicit
    'Author 3nvisi0n
    'Date: 15 October 2003
    'Purpose: General GUI Effects
    
    'Constants, this are normally defined in Windows.H so it's nice to have them here to
    'If you want to know more about these constants or other options for the External Functions declared bellow
    'Vist the Microsoft API
    Const LWA_COLORKEY = &H1
    Const LWA_ALPHA = &H2
    Const GWL_EXSTYLE = (-20)
    Const WS_EX_LAYERED = &H80000
    Const HWND_NOTOPMOST = -2
    Const HWND_TOPMOST = -1
    Const SWP_NOMOVE = &H2
    Const SWP_NOSIZE = &H1
    
    Const RGN_AND = 1
    Const RGN_OR = 2
    Const RGN_XOR = 3
    Const RGN_DIFF = 4
    Const RGN_COPY = 5
    'External Declarations from user32
    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
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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
    
    Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    
    
    'Useful Functions :)
    
    Public Declare Function FlashWindow Lib "User32" (ByVal hWnd As Long, ByVal bInvert As Boolean) As Long
        'Flashs the window, if you don't know what that means, this will make it obvious to the user that you want attention by flashing
        '   on most windows systems the tray icon will become orange, kinda hard to explain...
        'hwnd is the Window Handle for the form, you can get that with Property.hwnd ex. Me.Hwnd
        'bInvert is a flag to tell the browser to either flash the window between states, or to return to it's former state when complete
    
    Public Function SetTransparentColor(hWnd As Long, color As ColorConstants)
        'Only one color on a form can be transparent at a time
        'hwnd is the Window Handle for the form, you can get that with Property.hwnd ex. Me.Hwnd
        'color is the color to make transparent
        Dim r As Long
        r = GetWindowLong(hWnd, GWL_EXSTYLE)
        r = r Or WS_EX_LAYERED
        SetWindowLong hWnd, GWL_EXSTYLE, r
        SetLayeredWindowAttributes hWnd, color, 0, LWA_COLORKEY
    End Function
    
    Public Function FadeFormIn(hWnd As Long, Optional increment As Long = 1, Optional delayMS As Long = 10)
        'Obviously fades a given form into view
        'hwnd is the Window Handle for the form, you can get that with Property.hwnd ex. Me.Hwnd
        'Optional increment is used to determine the step length when fading in
        'Optional delayMS is used to determine how often to do steps, this will control how long it takes to fade in
        If increment < 1 Then increment = 1
        If delayMS < 0 Then delayMS = 0
        Dim r As Long
        r = GetWindowLong(hWnd, GWL_EXSTYLE)
        r = r Or WS_EX_LAYERED
        SetWindowLong hWnd, GWL_EXSTYLE, r
        
        Dim i As Integer
        For i = 0 To 255 Step increment
            SetLayeredWindowAttributes hWnd, 0, i, LWA_ALPHA
            Sleep delayMS
            DoEvents
        Next i
    End Function
    
    Public Function FadeFormOut(hWnd As Long, Optional increment As Long = 1, Optional delayMS As Long = 10)
        'Fades a given form out of view
        'hwnd is the Window Handle for the form, you can get that with Property.hwnd ex. Me.Hwnd
        'Optional increment is used to determine the step length when fading out
        'Optional delayMS is used to determine how often to do steps, this will control how long it takes to fade out
        If increment > -1 Then increment = -1
        If delayMS < 0 Then delayMS = 0
        Dim r As Long
        r = GetWindowLong(hWnd, GWL_EXSTYLE)
        r = r Or WS_EX_LAYERED
        SetWindowLong hWnd, GWL_EXSTYLE, r
        
        Dim i As Integer
        For i = 255 To 0 Step increment
            SetLayeredWindowAttributes hWnd, 0, i, LWA_ALPHA
            Sleep delayMS
            DoEvents
        Next i
    End Function
    
    Public Function SetFormTransparency(hWnd As Long, transp As Integer)
        Dim r As Long
        r = GetWindowLong(hWnd, GWL_EXSTYLE)
        r = r Or WS_EX_LAYERED
        SetWindowLong hWnd, GWL_EXSTYLE, r
        SetLayeredWindowAttributes hWnd, 0, transp, LWA_ALPHA
    End Function
    Public Function SetTopMost(hWnd As Long, Optional top As Boolean = True)
        'Sets the given hwnd as the topmost window so other windows will not appear on top of it, or removes it from this state
        'hwnd is the Window Handle for the form, you can get that with Property.hwnd ex. Me.Hwnd
        'Optional top is a flag use to determine if the window should be set as topmost or removed from topmost
        SetWindowPos hWnd, IIf(top, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, (SWP_NOMOVE + SWP_NOSIZE)
    End Function
    Public Function MakeShapedForm(f As Form, s As Object, Optional show As Boolean = False)
    'f is the Form, ex Me
    's is a single or an array of Shape object to be used
    'Optional show - determines if these shapes will be the only shown area, or the only transparent areas
    'Limitations: Only works with Rectangles, Rounded Rectangle are aproximated
    '              Only works when there is no form border
    'Notes:
    '   This is just an easy way to make the forums simply, you can expand from this code and manually create object instead of using the shapes in code.
    Dim rgnForm As Long
    Dim curShape As Long
    Dim rgnShapes As Long
    
     On Error GoTo Err
        rgnForm = CreateRectRgn(0, 0, f.ScaleX(f.Width, vbTwips, vbPixels), f.ScaleY(f.Height, vbTwips, vbPixels))
        rgnShapes = CreateRectRgn(0, 0, 0, 0)
        'lborder_width = (lFHeight - f.ScaleWidth) / 2
        'ltitle_height = lFHeight - lborder_width - f.ScaleHeight
    
        Dim tShape As Variant
        For Each tShape In s
            Select Case tShape.Shape
                Case 0
                    curShape = CreateRectRgn( _
                        f.ScaleX(tShape.Left, vbTwips, vbPixels), _
                        f.ScaleY(tShape.top, vbTwips, vbPixels), _
                        f.ScaleX(tShape.Left, vbTwips, vbPixels) + f.ScaleX(tShape.Width, vbTwips, vbPixels), _
                        f.ScaleY(tShape.top, vbTwips, vbPixels) + f.ScaleY(tShape.Height, vbTwips, vbPixels))
                        CombineRgn rgnShapes, rgnShapes, curShape, IIf(tShape.BackStyle = 0, RGN_OR, RGN_DIFF)
                Case 4
                'Not a perfect recration due to unknown elipse size on rounded rectangle shape
                    curShape = CreateRoundRectRgn( _
                        f.ScaleX(tShape.Left, vbTwips, vbPixels), _
                        f.ScaleY(tShape.top, vbTwips, vbPixels), _
                        f.ScaleX(tShape.Left, vbTwips, vbPixels) + f.ScaleX(tShape.Width, vbTwips, vbPixels), _
                        f.ScaleY(tShape.top, vbTwips, vbPixels) + f.ScaleY(tShape.Height, vbTwips, vbPixels), _
                        f.ScaleX(tShape.Width, vbTwips, vbPixels) / 10, _
                        f.ScaleY(tShape.Height, vbTwips, vbPixels) / 5)
                        CombineRgn rgnShapes, rgnShapes, curShape, IIf(tShape.BackStyle = 0, RGN_OR, RGN_DIFF)
            End Select
                DeleteObject curShape
        Next
        CombineRgn rgnForm, rgnForm, rgnShapes, IIf(show, RGN_AND, RGN_DIFF)
        SetWindowRgn f.hWnd, rgnForm, True
        DeleteObject rgnShapes
        DeleteObject rgnForm
        f.Refresh
    Exit Function
    
    Err:
         Debug.Print "-->E:" & Err.Number & ": " & Err.Description
    
    
    End Function
    
    EDIT: Found An example program I made last time I released this code...
    http://www.mediafire.com/?7430fk134sjt6zu
    And a picture
    [​IMG]

    AND I found the youtube video I made to show a bit of using the Module...
    http://www.youtube.com/watch?v=iB5jcFiac3M

    EDIT2: I'm finding all sorts of good stuff
    http://www.youtube.com/watch?v=0X6MJQjb3ns
    A Video showing the potential of the module
Thread Status:
This thread is more than 180 days old.

Share This Page