clswndeffects.cls

This application provides much functionality for creating data-driven reports, including preview, gr

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsWndEffects"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

Public Enum ceffHideShow
    ceffShow& = 0
    ceffHide& = 1
End Enum

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 Const ALTERNATE& = 1

Private Declare Function CreatePolyPolygonRgn Lib "gdi32" (lpPoint As POINTAPI, lpPolyCounts As Long, ByVal nCount As Long, ByVal nPolyFillMode 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 GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y 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 Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const RGN_OR& = 2

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 Const SWP_NOSIZE& = &H1
Private Const SWP_NOMOVE& = &H2
Private Const HWND_TOPMOST& = -1

Private hRgn As Long

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 crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Const GWL_EXSTYLE& = (-20)
Private Const WS_EX_LAYERED& = &H80000
Private Const LWA_ALPHA& = &H2


Private Sub SetWndRegion(ByVal hWnd As Long, ByVal hRgn As Long)
    Call SetWindowRgn(hWnd, hRgn, True)
End Sub

Public Sub SetWndRgn(ByVal hWnd As Long, picSkin As PictureBox)
    hRgn = MakeRegion(picSkin)
    SetWndRegion hWnd, hRgn
End Sub

Private Function MakeRegion(picSkin As PictureBox) As Long
Dim X As Long, Y As Long, StartLineX As Long
Dim FullRegion As Long, LineRegion As Long
Dim TransparentColor As Long
Dim InFirstRegion As Boolean
Dim InLine As Boolean
Dim hDC As Long
Dim PicWidth As Long
Dim PicHeight As Long

    hDC = picSkin.hDC
    PicWidth = picSkin.ScaleWidth
    PicHeight = picSkin.ScaleHeight
    InFirstRegion = True
    InLine = False
    TransparentColor = GetPixel(hDC, 0, 0)
    For Y = 0 To PicHeight - 1
        For X = 0 To PicWidth - 1
            If GetPixel(hDC, X, Y) = TransparentColor Or X = PicWidth Then
                If InLine Then
                    InLine = False
                    LineRegion = CreateRectRgn(StartLineX, Y, X, Y + 1)
                    If InFirstRegion Then
                        FullRegion = LineRegion
                        InFirstRegion = False
                    Else
                        CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
                        DeleteObject LineRegion
                    End If
                End If
            Else
                If Not InLine Then
                    InLine = True
                    StartLineX = X
                End If
            End If
        Next X
    Next Y
    MakeRegion = FullRegion
End Function

'use only for not sizable windows!!!
Public Sub HideOrShowRect(ByVal hWnd As Long, _
                                                    ByVal wCount As Long, _
                                                    ByVal hCount As Long, _
                                                    Optional ByVal ShowOrHide As ceffHideShow = 1, _
                                                    Optional ByVal Step_ As Long = 3)

Dim vertex() As POINTAPI, Num() As Long, wRect As RECT, n As Long
Dim RetVal As Long, St As Long, en As Long
Dim i As Long, j As Long, k As Long, m As Long, hIdx As Long, wIdx As Long, coef As Single
Dim w As Long, h As Long, oldw As Long, oldh As Long

    RetVal = GetWindowRect(hWnd, wRect)
    With wRect
        oldw = .Right - .Left
        w = Int(oldw / wCount) + 1
        oldh = .Bottom - .Top
        h = Int(oldh / hCount) + 1
    End With
    Select Case ShowOrHide
        Case 0
            St = 0
            en = w
            Step_ = Abs(Step_)
        Case 1
            St = w
            en = 0
            Step_ = -Abs(Step_)
        Case Else
            Err.Raise 5, , "ShowOrHide argument must be 0 or 1"
    End Select
    coef = w / h
    ReDim vertex(1 To wCount * hCount * 4)
    ReDim Num(1 To wCount * hCount)
    For n = St To en Step Step_
        For j = 1 To hCount
            For i = 1 To wCount
                m = (j - 1) * wCount + i
                k = (m - 1) * 4
                Num(m) = 4
                hIdx = (j - 1) * h
                wIdx = (i - 1) * w
                vertex(k + 1).X = wIdx
                vertex(k + 1).Y = hIdx
                vertex(k + 2).X = wIdx + n
                vertex(k + 2).Y = hIdx
                vertex(k + 3).X = wIdx + n
                vertex(k + 3).Y = hIdx + n / coef
                vertex(k + 4).X = wIdx
                vertex(k + 4).Y = hIdx + n / coef
            Next i
        Next j
        Sleep 10
        hRgn = CreatePolyPolygonRgn(vertex(1), Num(1), hCount * wCount, ALTERNATE)
        SetWndRegion hWnd, hRgn
        DoEvents
    Next n
End Sub

Public Sub GetWindowOnTop(ByVal hWnd As Long)
    Call SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 1, 1, SWP_NOSIZE Or SWP_NOMOVE)
End Sub

'use only for not sizable windows!!!
Public Sub HideOrShowRect2(ByVal hWnd As Long, _
                                                    Optional ByVal ShowOrHide As ceffHideShow = 1, _
                                                    Optional ByVal Step_ As Long = 3)

Dim wRect As RECT
Dim RetVal As Long, St As Long, en As Long
Dim n As Long, k As Single, coef As Single
Dim w As Long, h As Long

    RetVal = GetWindowRect(hWnd, wRect)
    With wRect
        w = (.Right - .Left) / 2
        h = (.Bottom - .Top) / 2
    End With
    Select Case ShowOrHide
        Case ceffShow
            St = 0
            en = w
            Step_ = Abs(Step_)
        Case ceffHide
            St = w
            en = 0
            Step_ = -Abs(Step_)
        Case Else
            Err.Raise 5, , "ShowOrHide argument must be 0 or 1"
    End Select
    coef = w / h
    For n = St To en Step Step_
        k = n / coef
        hRgn = CreateRectRgn(w - n, h - k, w + n, h + k)
        SetWndRegion hWnd, hRgn
        Sleep 10
        DoEvents
    Next n
End Sub

Public Function DeleteObj() As Long
    DeleteObj = DeleteObject(hRgn)
End Function

Public Sub MakeTransparent(hWnd As Long, TransparencyLevel As Byte)
Dim lngOldStyle As Long

    On Error GoTo ErrHandler:
    If hWnd <> 0 Then
        lngOldStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
        Call SetWindowLong(hWnd, GWL_EXSTYLE, lngOldStyle Or WS_EX_LAYERED)
        Call SetLayeredWindowAttributes(hWnd, 0, TransparencyLevel, LWA_ALPHA)
    End If

ErrHandler:
End Sub