Attribute VB_Name = "modThumbs"
' ======================================================================================
' Name:     DeskShots 1.0
' Author:   Joshy Francis (joshylogicss@yahoo.co.in)
' Date:     14 May 2007
'
' Requires: None
'
' Copyright © 2000-2007 Joshy Francis
' --------------------------------------------------------------------------------------
'The Wallpaper changing Utility.
'   *********Features**********
'   1. Simple & Powerful Thumbnail Viewer.
'   2. Moving & Replacing of Images in List done very very fast.
'   3. Uses own Database System.
'   4. Different Settings can be applied to each files in list.
'   5. Drag-N-Drop Supporting.
'   6. Change wallpaper in timed intervals.Can Set Any Interval.
'   7. Startup.
'   8. Tray Notification.Can Simply control from System Tray.
'   9. Can Change wallpaper Sequentially or randomly.
'   10. Also includes many other useful functions related to Array,ListView,File Programming,
'       Common Dialog Control API,System Tray Application,Startup Application etc.
'       Array Functions include moving an item in array to another position.Faster Array operations,
'       Saving Array to File,Reading Array from File etc.
'       Simple Progressbar code is included.
'       A Simple & powerful ListView Technique is established.
'   *****************************************
'you can freely use this code anywhere.But I wants you must include the Copyright Info
'some of the functions from PSC
' --------------------------------------------------------------------------------------
'I Will include comments after a few days.Please wait.

'Please..........Vote my program...
Option Explicit
Private Declare Function StretchBlt Lib "gdi32" (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 dwRop As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal hStretchMode As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Type Bitmap '14 bytes
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Const LR_DEFAULTCOLOR = &H0
Public Const LR_MONOCHROME = &H1
Public Const LR_COLOR = &H2
Public Const LR_COPYRETURNORG = &H4
Public Const LR_COPYDELETEORG = &H8
Public Const LR_LOADFROMFILE = &H10
Public Const LR_LOADTRANSPARENT = &H20
Public Const LR_DEFAULTSIZE = &H40
Public Const LR_VGACOLOR = &H80
Public Const LR_LOADMAP3DCOLORS = &H1000
Public Const LR_CREATEDIBSECTION = &H2000
Public Const LR_COPYFROMRESOURCE = &H4000
Public Const LR_SHARED = &H8000
Public Const IMAGE_BITMAP = 0
Public Const IMAGE_ICON = 1
Public Const IMAGE_CURSOR = 2
Public Const IMAGE_ENHMETAFILE = 3
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Public Const STRETCHMODE = vbPaletteModeNone   'You can find other modes in the "PaletteModeConstants" section of your Object Browser
Public Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Public Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Public Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Public Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
Public Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Public Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
Public Const OCR_CROSS = 32515
Public Const OCR_IBEAM = 32513
Public Const OCR_ICOCUR = 32647
Public Const OCR_ICON = 32641
Public Const OCR_NO = 32648 ' not in win3.1
Public Const OCR_NORMAL = 32512
Public Const OCR_SIZE = 32640
Public Const OCR_SIZEALL = 32646
Public Const OCR_SIZENESW = 32643
Public Const OCR_SIZENS = 32645
Public Const OCR_SIZENWSE = 32642
Public Const OCR_SIZEWE = 32644
Public Const OCR_UP = 32516
Public Const OCR_WAIT = 32514
Public Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
Public Declare Function GetTextExtentPoint Lib "gdi32" Alias "GetTextExtentPointA" (ByVal hDC As Long, ByVal lpszString As String, ByVal cbString As Long, lpSize As Size) As Long
Public Type Size
        cx As Long
        cy As Long
End Type
Public Declare Function InitCommonControls Lib "COMCTL32.DLL" () As Long
Public Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Public Const GENERIC_ALL = &H10000000
Public Const GENERIC_EXECUTE = &H20000000
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const CREATE_ALWAYS = 2
Public Const CREATE_NEW = 1
Public Const OPEN_ALWAYS = 4
Public Const OPEN_EXISTING = 3
Public Const TRUNCATE_EXISTING = 5
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
Public Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000
Public Const FILE_FLAG_DELETE_ON_CLOSE = &H4000000
Public Const FILE_FLAG_NO_BUFFERING = &H20000000
Public Const FILE_FLAG_OVERLAPPED = &H40000000
Public Const FILE_FLAG_POSIX_SEMANTICS = &H1000000
Public Const FILE_FLAG_RANDOM_ACCESS = &H10000000
Public Const FILE_FLAG_SEQUENTIAL_SCAN = &H8000000
Public Const FILE_FLAG_WRITE_THROUGH = &H80000000
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long
Public Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
End Type
Public Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Public Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Public Const FILE_BEGIN = 0
Public Const FILE_END = 2
Public Const FILE_CURRENT = 1
Public Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Public Const DFC_BUTTON = 4
Public Const DFC_CAPTION = 1
Public Const DFC_MENU = 2
Public Const DFC_SCROLL = 3
Public Const DFC_POPUPMENU = 5
Public Const DFCS_ADJUSTRECT = &H2000
Public Const DFCS_BUTTON3STATE = &H8
Public Const DFCS_BUTTONCHECK = &H0
Public Const DFCS_BUTTONPUSH = &H10
Public Const DFCS_BUTTONRADIO = &H4
Public Const DFCS_BUTTONRADIOIMAGE = &H1
Public Const DFCS_BUTTONRADIOMASK = &H2
Public Const DFCS_CAPTIONCLOSE = &H0
Public Const DFCS_CAPTIONHELP = &H4
Public Const DFCS_CAPTIONMAX = &H2
Public Const DFCS_CAPTIONMIN = &H1
Public Const DFCS_CAPTIONRESTORE = &H3
Public Const DFCS_CHECKED = &H400
Public Const DFCS_FLAT = &H4000
Public Const DFCS_INACTIVE = &H100
Public Const DFCS_MENUARROW = &H0
Public Const DFCS_MENUARROWRIGHT = &H4
Public Const DFCS_MENUBULLET = &H2
Public Const DFCS_MENUCHECK = &H1
Public Const DFCS_MONO = &H8000
Public Const DFCS_PUSHED = &H200
Public Const DFCS_SCROLLCOMBOBOX = &H5
Public Const DFCS_SCROLLDOWN = &H1
Public Const DFCS_SCROLLLEFT = &H2
Public Const DFCS_SCROLLRIGHT = &H3
Public Const DFCS_SCROLLSIZEGRIP = &H8
Public Const DFCS_SCROLLSIZEGRIPRIGHT = &H10
Public Const DFCS_SCROLLUP = &H0
Public Const DFCS_TRANSPARENT = &H800
Public Const DFCS_HOT = &H1000

'* 3D border styles *'
Public Const BDR_RAISEDOUTER = &H1
Public Const BDR_SUNKENOUTER = &H2
Public Const BDR_RAISEDINNER = &H4
Public Const BDR_SUNKENINNER = &H8

Public Const BDR_OUTER = (BDR_RAISEDOUTER Or BDR_SUNKENOUTER)
Public Const BDR_INNER = (BDR_RAISEDINNER Or BDR_SUNKENINNER)
Public Const BDR_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Public Const BDR_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)


Public Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Public Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Public Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Public Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)

'* Border flags *'
Public Const BF_LEFT = &H1
Public Const BF_TOP = &H2
Public Const BF_RIGHT = &H4
Public Const BF_BOTTOM = &H8

Public Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Public Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Public Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Public Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Public Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Public Const BF_DIAGONAL = &H10

'' For diagonal lines, the BF_RECT flags specify the end point of the
'' vector bounded by the rectangle parameter.
Public Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)
Public Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Public Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Public Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)


Public Const BF_MIDDLE = &H800         '* Fill in the middle *'
Public Const BF_SOFT = &H1000          '* For softer buttons *'
Public Const BF_ADJUST = &H2000        '* Calculate the space left over *'
Public Const BF_FLAT = &H4000          '* For flat rather than 3D borders *'
Public Const BF_MONO = &H8000          '* For monochrome borders *'
Public Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Public Declare Function DrawEscape Lib "gdi32" (ByVal hDC As Long, ByVal nEscape As Long, ByVal cbInput As Long, ByVal lpszInData As String) As Long
Public Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, lpRect As RECT) As Long
Public Declare Function DrawFrameControl Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetCursor Lib "user32" () As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Public Type TypeThumb
    sFile As String
    Width As Integer
    Height As Integer
    W As Integer
    H As Integer
    attr As Byte
    hBmp As Long
    Style As String
End Type
Public ThumbCount As Long
Public Thumbs() As TypeThumb
Public ThumbW As Integer, ThumbH As Integer
Public VSpace As Integer, HSpace As Integer

Sub SelectThumb(ByVal Idx As Long)
    If Idx >= ThumbCount Or Idx < 0 Then Exit Sub
Thumbs(Idx).attr = Thumbs(Idx).attr Or 2
End Sub
Sub UnSelectThumb(ByVal Idx As Long)
    If Idx >= ThumbCount Or Idx < 0 Then Exit Sub
Thumbs(Idx).attr = Thumbs(Idx).attr And Not 2
End Sub
Sub RefreshThumb(ByVal Idx As Long)
If Idx >= ThumbCount Or Idx < 0 Then Exit Sub
On Error Resume Next
With Thumbs(Idx)
    If .hBmp = -1 Then
            Screen.MousePointer = 11
        Dim hBmp As Long 'StdPicture
        Dim hBmpTemp As Long
'        If InStr(LCase$(.sFile), ".png") Or InStr(LCase$(.sFile), ".tif") Then
'            Set hBmp = LoadPictureEx(.sFile)
'        Else
'            Set hBmp = LoadPicture(.sFile)
'        End If
'                If hBmp Is Nothing Then
'                    Set hBmp = LoadPictureEx(.sFile)
        Dim gplRet        As Long
        Dim hImg          As Long
'        Dim hBmp          As Long
          
          '-- Load image
          gplRet = GdipLoadImageFromFile(StrConv(.sFile, vbUnicode), hImg)
          
          '-- Create bitmap
          gplRet = GdipCreateHBITMAPFromBitmap(hImg, hBmp, vbBlack)
          
          '-- Free image
          gplRet = GdipDisposeImage(hImg)
    
        If (gplRet = [OK]) Then
    '                End If
'                hBmpTemp = CopyImage(hBmp.handle, 0, ThumbW, ThumbH, LR_COPYDELETEORG)
                hBmpTemp = CopyImage(hBmp, 0, ThumbW, ThumbH, LR_COPYDELETEORG)
            '******** Keeping Aspect Ratio ****************
'            .W = hBmp.Width
                    .Width = .W / 26.45875
                .W = .W \ ThumbW
                .W = Abs(ThumbW - .W)
'            .H = hBmp.Height
                    .Height = .H / 26.4583333333333
                .H = .W \ ThumbH
                .H = Abs(ThumbH - .H)
            '*********************************************
            .hBmp = ImageList_Add(hIml, hBmpTemp, 0)
                DeleteObject hBmpTemp
'            Set hBmp = Nothing
                If .hBmp = -1 Then
                    DeleteThumb Idx
                End If
            Screen.MousePointer = 0
        End If
    End If
End With
End Sub
Sub DispThumb(Pic As PictureBox, VS As VScrollBar, ByVal CurSel As Long, _
    picProg As PictureBox, Optional ByVal DoRefresh As Boolean = False)
Dim x As Long, X2 As Long, C As Long, Xpos As Integer, YPos As Integer
Dim VisibleCount As Integer, str As String, hBmp As StdPicture, Refreshed As Boolean
        If ThumbH = 0 Then ThumbH = 64
        If ThumbW = 0 Then ThumbW = 64
'    C = Pic.ScaleWidth \ ThumbW
    C = (Pic.ScaleWidth - (VS.Width + HSpace)) \ ThumbW
'    VisibleCount = (Pic.ScaleHeight \ ThumbH) * c
    VisibleCount = ((Pic.ScaleHeight - (VSpace + picProg.Height)) \ ThumbH) * C
''        X2 = ThumbCount + 1
''        Pic.AutoRedraw = False
    Pic.Cls
        X2 = VS.Value * (C)
    '***************for displaying bottom row *************
            VisibleCount = VisibleCount + C
    '******************************************************
            Dim I As Long
            Static PrevX2 As Long
                If X2 <> PrevX2 Then
                    ImageList_Destroy hIml
                        hIml = 0
                    For I = 0 To ThumbCount - 1
                        If Thumbs(I).hBmp <> -1 Then
                                Thumbs(I).hBmp = -1
                        End If
                    Next
                End If
                        PrevX2 = X2
        If hIml = 0 Then
            hIml = ImageList_Create(ThumbW, ThumbH, ILC_COLORDDB, 1, 1)
            DoRefresh = True
        End If
For x = 0 To VisibleCount - 1 'ThumbCount - 1
        If X2 >= ThumbCount Or X2 < 0 Then Exit For
On Error Resume Next
    With Thumbs(X2)
        If .attr > 0 Then
            On Error Resume Next
'                If DoRefresh = True Or .W <= 0 Then
                If .hBmp = -1 Then
                        Refreshed = True
                    RefreshThumb X2
                        Progress picProg.hwnd, VisibleCount - 1, x + 1, , , "Refreshing Thumbs..."
                End If
            If x = 0 Then
                Xpos = 0
            Else
                Xpos = (x Mod C)
                    Xpos = Xpos * ThumbW
            End If
            If x = 0 Then
                YPos = 0
            Else
                YPos = (x \ C) * ThumbH
            End If
                Dim DrawFlag As Long
                Dim RC As RECT
                    RC.left = Xpos: RC.top = YPos
                    RC.right = RC.left + ThumbW: RC.bottom = RC.top + ThumbH
                        DrawFlag = DFCS_ADJUSTRECT Or DFCS_BUTTONPUSH
                    If (.attr And 2) = 2 Then
                        DrawFlag = DrawFlag Or DFCS_PUSHED
                    End If
            DrawFrameControl Pic.hDC, RC, DFC_BUTTON, DrawFlag
                        DrawFlag = ILD_NORMAL
                    If (.attr And 2) = 2 Then
                        If X2 <> CurSel Then
                            DrawFlag = DrawFlag Or ILD_SELECTED Or ILD_FOCUS
                        Else
                            DrawFlag = DrawFlag
                        End If
                    End If
                ImageList_DrawEx hIml, .hBmp, Pic.hDC, Xpos + HSpace, YPos, ThumbW - HSpace, ThumbH - VSpace, 0, 0, DrawFlag
                        str = StretchText(Pic.hDC, Dir(.sFile), 14)
                    TextOut Pic.hDC, Xpos + 2, (YPos + ThumbH) - VSpace, str, Len(str)
                If (.attr And 2) = 2 Then
                        Pic.ForeColor = vbRed
                    Rectangle Pic.hDC, Xpos, YPos, Xpos + ThumbW, YPos + ThumbH
                    If X2 = CurSel Then
                        RC.left = RC.left + 1: RC.top = RC.top + 1
                        RC.right = RC.right - 1: RC.bottom = RC.bottom - 1
                        DrawFocusRect Pic.hDC, RC
                    End If
                        Pic.ForeColor = vbBlack
                End If
        End If
    End With
        X2 = X2 + 1
Next
Dim UnVisibleCount As Integer
'    VisibleCount = CInt(Pic.ScaleHeight / ThumbH) * C
    VisibleCount = CInt((Pic.ScaleHeight - (VSpace + picProg.Height)) \ ThumbH) * C
UnVisibleCount = (ThumbCount - VisibleCount)
If C = 0 Then Exit Sub
    If UnVisibleCount >= 1 Then
        VS.Max = (UnVisibleCount / C) + 1
        VS.SmallChange = 1
        VS.LargeChange = (Pic.ScaleHeight - (VSpace + picProg.Height)) \ ThumbH
            VS.Width = 20
            VS.Visible = True
        VS.Refresh
    Else
        VS.Max = 0
        VS.SmallChange = 1
        VS.LargeChange = 1
            VS.Width = 0
            VS.Visible = False
    End If
With VS
    .Move Pic.ScaleWidth - .Width, 0, .Width, Pic.ScaleHeight - picProg.Height
End With
'With picProg
'    .Move 0, Pic.ScaleHeight - Pic.Height, Pic.ScaleWidth
'End With
Pic.Refresh
    If Refreshed = True Then
        picProg.Cls
    End If
End Sub
Sub SaveThumbs(ByVal sFile As String)
On Error GoTo E
    If Dir(sFile) <> "" Then Kill sFile
Open sFile For Binary As 1
    Seek #1, 1
        Put #1, , ThumbCount
        Put #1, , Thumbs
Close 1
Exit Sub
E:
MsgBox Err.Description, vbCritical
End Sub
Sub LoadThumbs(ByVal sFile As String, Pic As PictureBox, VS As VScrollBar, Prog As PictureBox, Optional ByVal Reload As Boolean = False)
On Error GoTo E
Dim tmp() As TypeThumb, C As Long, Count As Long, hBmp As IPictureDisp, hTmp As Long
Open sFile For Binary As 1
    Seek #1, 1
        Get #1, , Count
    If Count <> 0 Then
            ReDim tmp(Count - 1)
                CleanThumbs
                    If hIml = 0 Then
                        hIml = ImageList_Create(ThumbW, ThumbH, ILC_COLORDDB, 1, 1)
                    End If
            ReDim Thumbs(Count - 1)
                ThumbCount = Count
        Get #1, , tmp
            For C = 0 To Count - 1
                On Error Resume Next
'                DispNewThumb Pic, tmp(c).sFile, LoadPicture(tmp(c).sFile), VS, False, Prog
                With Thumbs(C)
                    .attr = tmp(C).attr
                    .sFile = tmp(C).sFile
                            .W = 0
                            .H = 0
                            .hBmp = -1
'                        RefreshThumb C
                    .Style = tmp(C).Style
                End With
'                        frmSplash.PicProgress.Cls
                If Reload = False Then
                    Progress frmSplash.PicProgress.hwnd, Count, C ', &HFF8080
                Else
                    Progress Prog.hwnd, Count, C + 1 ', &HFF8080
                End If
'                        frmSplash.PicProgress.ForeColor = QBColor(Rnd * 15)
'                            frmSplash.PicProgress.Print "Loading..."
                        DoEvents
            Next
        Erase tmp
    End If
Close 1
'    Prog.Cls
        Pic.AutoRedraw = True
    DispThumb Pic, VS, ThumbCount - 1, Prog
Exit Sub
E:
MsgBox Err.Description, vbCritical
End Sub
Sub AddThumb(ByVal sFile As String)
        If hIml = 0 Then
            hIml = ImageList_Create(ThumbW, ThumbH, ILC_COLORDDB, 1, 1)
        End If
ReDim Preserve Thumbs(ThumbCount)
    With Thumbs(ThumbCount)
        .sFile = sFile
        .attr = 1
        .Style = "Center"
        .hBmp = -1
    End With
ThumbCount = ThumbCount + 1
End Sub
Sub DeleteThumb(ByVal Idx As Integer)
Dim tmp() As TypeThumb, C As Long, Count As Long, x As Long
    Count = ThumbCount
        If Count <= 1 Then
'            Erase Thumbs
'            ThumbCount = 0
            CleanThumbs
            Exit Sub
        End If
Screen.MousePointer = 11
    If Thumbs(Idx).hBmp <> -1 Then ImageList_Remove Idx, Thumbs(Idx).hBmp
ReDim tmp(Count - 2)
        x = 0
    For C = 0 To Count - 1
        If C <> Idx Then
            With tmp(x)
                .attr = Thumbs(C).attr
                .H = Thumbs(C).H
                .hBmp = Thumbs(C).hBmp
                .sFile = Thumbs(C).sFile
                .Style = Thumbs(C).Style
                .W = Thumbs(C).W
                .Width = Thumbs(C).Width
                .Height = Thumbs(C).Height
            End With
                x = x + 1
        End If
    Next
ThumbCount = ThumbCount - 1
    Erase Thumbs
        ReDim Thumbs(ThumbCount - 1)
For C = 0 To ThumbCount - 1
        With Thumbs(C)
            .attr = tmp(C).attr
            .H = tmp(C).H
            .hBmp = tmp(C).hBmp
            .sFile = tmp(C).sFile
            .Style = tmp(C).Style
            .W = tmp(C).W
            .Width = tmp(C).Width
            .Height = tmp(C).Height
        End With
Next
    Erase tmp
Screen.MousePointer = 0
End Sub
Sub MoveThumb(ByVal Idx As Long, ByVal Dest As Long, Optional ByVal UnSelectOld As Boolean = True)
If Idx >= ThumbCount Or Idx < 0 Then Exit Sub
If Dest >= ThumbCount Or Dest < 0 Then Exit Sub
Dim tmp()   As TypeThumb, C As Long, I As Long
    ReDim tmp(ThumbCount - 1)
        For C = 0 To ThumbCount - 1
            CopyThumb Thumbs(C), tmp(C)
        Next
    Erase Thumbs
        I = 0
If Idx > Dest Then
        I = 0
    For C = 0 To Dest - 1
            ReDim Preserve Thumbs(I)
        CopyThumb tmp(C), Thumbs(I)
            I = I + 1
    Next
            ReDim Preserve Thumbs(I)
        CopyThumb tmp(Idx), Thumbs(I)
            I = I + 1
    For C = Dest To ThumbCount - 1
        If C <> Idx Then
                ReDim Preserve Thumbs(I)
            CopyThumb tmp(C), Thumbs(I)
                I = I + 1
        End If
    Next
        If UnSelectOld = True Then
            Thumbs(Dest + 1).attr = Thumbs(Dest + 1).attr And Not 2
        End If
Else 'Idx < Dest
        I = 0
    For C = 0 To Idx - 1
            ReDim Preserve Thumbs(I)
        CopyThumb tmp(C), Thumbs(I)
            I = I + 1
    Next
    For C = Idx + 1 To Dest '- 1
            ReDim Preserve Thumbs(I)
        CopyThumb tmp(C), Thumbs(I)
            I = I + 1
    Next
            ReDim Preserve Thumbs(I)
        CopyThumb tmp(Idx), Thumbs(I)
            I = I + 1
    For C = Dest + 1 To ThumbCount - 1
            ReDim Preserve Thumbs(I)
        CopyThumb tmp(C), Thumbs(I)
            I = I + 1
    Next
        If UnSelectOld = True Then
            Thumbs(Dest - 1).attr = Thumbs(Dest - 1).attr And Not 2
        End If
End If
    Erase tmp
End Sub
Sub CopyThumb(tFrom As TypeThumb, tTo As TypeThumb)
With tTo
    .attr = tFrom.attr
    .H = tFrom.H
    .hBmp = tFrom.hBmp
    .Height = tFrom.Height
    .sFile = tFrom.sFile
    .Style = tFrom.Style
    .W = tFrom.W
    .Width = tFrom.Width
End With
End Sub

Sub ReplaceThumb(ByVal Idx As Long, ByVal Dest As Long, Optional ByVal UnSelectOld As Boolean = True)
If Idx >= ThumbCount Or Idx < 0 Then Exit Sub
If Dest >= ThumbCount Or Dest < 0 Then Exit Sub
Dim tmp  As TypeThumb, C As Long
For C = 0 To ThumbCount - 1
    If C = Idx Then
        With tmp
            .attr = Thumbs(C).attr
            .H = Thumbs(C).H
            .hBmp = Thumbs(C).hBmp
            .sFile = Thumbs(C).sFile
            .Style = Thumbs(C).Style
            .W = Thumbs(C).W
            .Width = Thumbs(C).Width
            .Height = Thumbs(C).Height
        End With
            Exit For
    End If
Next
For C = 0 To ThumbCount - 1
    If C = Dest Then
        With Thumbs(Idx)
            .attr = Thumbs(C).attr
                If UnSelectOld = True Then
                    .attr = .attr And Not 2
                End If
            .H = Thumbs(C).H
            .hBmp = Thumbs(C).hBmp
            .sFile = Thumbs(C).sFile
            .Style = Thumbs(C).Style
            .W = Thumbs(C).W
            .Width = Thumbs(C).Width
            .Height = Thumbs(C).Height
        End With
            With Thumbs(C)
                .attr = tmp.attr
                .H = tmp.H
                .hBmp = tmp.hBmp
                .sFile = tmp.sFile
                .Style = tmp.Style
                .W = tmp.W
                .Width = tmp.Width
                .Height = tmp.Height
            End With
    End If
Next
End Sub
Function StretchText(ByVal hDC As Long, ByVal str As String, Optional ByVal cb As Long) As String
Dim WC As Integer, C As Integer, strOut As String, S As Size, SA As Size
        GetTextExtentPoint32 hDC, "A", 1, SA
        GetTextExtentPoint32 hDC, str, Len(str), S
    If cb <> 0 Then
        WC = cb
    Else
        WC = CInt(S.cx \ SA.cx)
    End If
C = Len(str)
    If C > WC Then
        C = WC
                WC = (C \ 2) - 3
                C = C - WC
        strOut = left$(str, WC)
        strOut = strOut & "..." & right$(str, C - 3)
    Else
        strOut = str
    End If
StretchText = strOut
End Function

Sub CleanThumbs()
Dim x As Long
    For x = 0 To ThumbCount - 1
'        Set Thumbs(X).hBmp = Nothing
    Next
Erase Thumbs
    ThumbCount = 0
If hIml <> 0 Then
    ImageList_Destroy hIml
        hIml = 0
End If
End Sub
Sub ScrollToThumb(Pic As PictureBox, VS As VScrollBar, Prog As PictureBox, ByVal Idx As Long)
On Error Resume Next
Dim Rows As Long, Cols As Long, ItemsInPage As Long, Pages As Long, RowsInPage As Long
    Cols = (Pic.ScaleWidth - (VS.Width + HSpace)) \ ThumbW
    Rows = (Pic.ScaleHeight - (VSpace + Prog.Height)) \ ThumbH
ItemsInPage = Cols * Rows
    If Idx < ItemsInPage Then
        Pages = 0
    Else
        Pages = (Idx / ItemsInPage) + 1
    End If
RowsInPage = (ThumbCount / Rows) + 1
    If Idx >= ThumbCount Or Idx < 0 Then Exit Sub
VS.Value = Pages * 2
    
End Sub
Function RowsInPage(Pic As PictureBox, VS As VScrollBar, Prog As PictureBox) As Long
Dim Rows As Long, Cols As Long, ItemsInPage As Long, Pages As Long
    Cols = (Pic.ScaleWidth - (VS.Width + HSpace)) \ ThumbW
    Rows = (Pic.ScaleHeight - (VSpace + Prog.Height)) \ ThumbH
ItemsInPage = Cols * Rows
    Pages = (ThumbCount / ItemsInPage) + 1
RowsInPage = (ThumbCount / Rows) + 1
End Function
Function NoOfPages(Pic As PictureBox, VS As VScrollBar, Prog As PictureBox) As Long
Dim Rows As Long, Cols As Long, ItemsInPage As Long, Pages As Long
    Cols = (Pic.ScaleWidth - (VS.Width + HSpace)) \ ThumbW
    Rows = (Pic.ScaleHeight - (VSpace + Prog.Height)) \ ThumbH
ItemsInPage = Cols * Rows
    Pages = (ThumbCount / ItemsInPage) + 1
NoOfPages = Pages
End Function

Function LoadImageFromFile(ByVal sFile As String) As Long
Dim nType As Long
    If InStr(LCase$(sFile), ".wmf") Or InStr(LCase$(sFile), ".emf") Then
        nType = IMAGE_ENHMETAFILE
    ElseIf InStr(LCase$(sFile), ".bmp") Then
        nType = IMAGE_BITMAP
    ElseIf InStr(LCase$(sFile), ".ico") Then
        nType = IMAGE_ICON
    ElseIf InStr(LCase$(sFile), ".cur") Then
        nType = IMAGE_CURSOR
    Else
        On Error Resume Next
            LoadImageFromFile = LoadPicture(sFile).handle
        Exit Function
    End If
LoadImageFromFile = LoadImage(ByVal 0, sFile, nType, ByVal 0, ByVal 0, _
    LR_LOADFROMFILE Or LR_DEFAULTSIZE)
End Function
Function StretchBmp(ByVal hDC As Long, ByVal hBmp As Long, ByVal x As Long, _
    ByVal Y As Long, Optional ByVal W As Long = 64, _
        Optional ByVal H As Long = 64) As Long
Dim OldStretchBltMode As Long, HdcMem As Long, hBmpMem As Long
Dim BM As Bitmap, Ret As Long
    OldStretchBltMode = SetStretchBltMode(hDC, vbPaletteModeNone)
        HdcMem = CreateCompatibleDC(hDC)
'        hBmpMem = CreateCompatibleBitmap(HdcMem, W, H)
        hBmpMem = SelectObject(HdcMem, hBmp)
    Ret = GetObject(hBmp, Len(BM), BM)
        If Ret <> Len(BM) Then
            GoTo MemFree
            Exit Function
        End If
StretchBmp = StretchBlt(hDC, x, Y, W, H, HdcMem, 0, 0, BM.bmWidth, BM.bmHeight, vbSrcCopy)
            DeleteObject hBmpMem
MemFree:
            DeleteDC HdcMem
    SetStretchBltMode hDC, OldStretchBltMode
End Function
