Planet Source Code Jumbo …e CD Visual Basic 1 to 7/3_2004-2005.ISO/Data/Zips/VB_Recent_1869643302005.psc/fRecent.frm

Text File | 2005-03-30 | 45KB | 1,299 lines

VERSION 5.00
Begin VB.Form fRecent
   BackColor       =   &H00E8E0E0&
   BorderStyle     =   1  'Fest Einfach
   ClientHeight    =   3975
   ClientLeft      =   45
   ClientTop       =   390
   ClientWidth     =   11220
   Icon            =   "fRecent.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3975
   ScaleWidth      =   11220
   Begin VB.PictureBox picSortBy
      BackColor       =   &H0080C0FF&
      BorderStyle     =   0  'Kein
      Height          =   1590
      Left            =   4373
      ScaleHeight     =   1590
      ScaleWidth      =   2490
      TabIndex        =   12
      Top             =   1192
      Width           =   2490
      Begin VB.OptionButton optFN
         BackColor       =   &H0080C0FF&
         ForeColor       =   &H00004080&
         Height          =   195
         Left            =   405
         TabIndex        =   14
         Top             =   465
         Width           =   195
      End
      Begin VB.OptionButton optPN
         BackColor       =   &H0080C0FF&
         ForeColor       =   &H00004080&
         Height          =   195
         Left            =   405
         TabIndex        =   16
         Top             =   780
         Width           =   195
      End
      Begin VB.OptionButton optCH
         BackColor       =   &H0080C0FF&
         ForeColor       =   &H00004080&
         Height          =   195
         Left            =   405
         TabIndex        =   18
         Top             =   1095
         Value           =   -1  'True
         Width           =   195
      End
      Begin VB.Label lbClose
         Alignment       =   2  'Zentriert
         BackColor       =   &H000000FF&
         Caption         =   "r"
         BeginProperty Font
            Name            =   "Marlett"
            Size            =   9.75
            Charset         =   2
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00C0FFFF&
         Height          =   195
         Left            =   2220
         TabIndex        =   20
         ToolTipText     =   "Close"
         Top             =   75
         Width           =   210
      End
      Begin VB.Label lb
         Alignment       =   1  'Rechts
         BackColor       =   &H00FFFFFF&
         BackStyle       =   0  'Transparent
         Caption         =   "chronologically"
         ForeColor       =   &H00004080&
         Height          =   195
         Index           =   2
         Left            =   585
         TabIndex        =   17
         Top             =   1095
         Width           =   1140
      End
      Begin VB.Label lb
         Alignment       =   1  'Rechts
         BackColor       =   &H00000000&
         BackStyle       =   0  'Transparent
         Caption         =   "by Project Name"
         ForeColor       =   &H00004080&
         Height          =   195
         Index           =   1
         Left            =   585
         TabIndex        =   15
         Top             =   780
         Width           =   1260
      End
      Begin VB.Label lb
         Alignment       =   1  'Rechts
         BackColor       =   &H00000000&
         BackStyle       =   0  'Transparent
         Caption         =   "by Path Name"
         ForeColor       =   &H00004080&
         Height          =   195
         Index           =   0
         Left            =   600
         TabIndex        =   13
         Top             =   465
         Width           =   1095
      End
      Begin VB.Line ln
         BorderColor     =   &H0000A0FF&
         BorderWidth     =   3
         Index           =   0
         X1              =   45
         X2              =   2505
         Y1              =   1560
         Y2              =   1560
      End
      Begin VB.Line ln
         BorderColor     =   &H0000A0FF&
         BorderWidth     =   3
         Index           =   1
         X1              =   2460
         X2              =   2460
         Y1              =   30
         Y2              =   1530
      End
      Begin VB.Line ln
         BorderColor     =   &H00C0E0FF&
         BorderWidth     =   3
         Index           =   3
         X1              =   15
         X2              =   15
         Y1              =   0
         Y2              =   1605
      End
      Begin VB.Line ln
         BorderColor     =   &H00C0E0FF&
         BorderWidth     =   3
         Index           =   2
         X1              =   0
         X2              =   2445
         Y1              =   15
         Y2              =   15
      End
      Begin VB.Label lbTitle
         BackColor       =   &H00000000&
         BackStyle       =   0  'Transparent
         Caption         =   "Sort..."
         BeginProperty Font
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00004080&
         Height          =   240
         Left            =   210
         TabIndex        =   19
         Top             =   135
         Width           =   615
      End
   End
   Begin VB.CommandButton btSave
      Caption         =   "Up&date"
      Height          =   420
      Left            =   4050
      TabIndex        =   26
      ToolTipText     =   "Store long path names in registry"
      Top             =   3405
      Width           =   1050
   End
   Begin VB.PictureBox picSep
      Appearance      =   0  '2D
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   390
      Left            =   5985
      ScaleHeight     =   360
      ScaleWidth      =   0
      TabIndex        =   25
      Top             =   3420
      Width           =   15
   End
   Begin VB.PictureBox picFire
      BorderStyle     =   0  'Kein
      Height          =   180
      Left            =   9480
      ScaleHeight     =   180
      ScaleWidth      =   165
      TabIndex        =   23
      Top             =   3765
      Width           =   165
      Begin VB.Label lbFire
         BackColor       =   &H00E0E0E0&
         Caption         =   "±"
         BeginProperty Font
            Name            =   "Wingdings"
            Size            =   11.25
            Charset         =   2
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   -15
         TabIndex        =   24
         ToolTipText     =   "Light my fire..."
         Top             =   -30
         Width           =   210
      End
   End
   Begin VB.CommandButton btUndo
      Caption         =   " &Undo"
      Height          =   420
      Left            =   5925
      TabIndex        =   22
      ToolTipText     =   "Can't undo"
      Top             =   3405
      Width           =   645
   End
   Begin VB.CommandButton btDone
      Cancel          =   -1  'True
      Caption         =   "&E&xit"
      Height          =   420
      Left            =   9930
      TabIndex        =   7
      ToolTipText     =   "Good bye"
      Top             =   3405
      Width           =   1080
   End
   Begin VB.CommandButton btRunVB6
      Caption         =   "Launch &VB6"
      Height          =   420
      Left            =   8100
      MaskColor       =   &H00FFFFFF&
      TabIndex        =   5
      ToolTipText     =   "Run VB6"
      Top             =   3405
      UseMaskColor    =   -1  'True
      Width           =   1320
   End
   Begin VB.CommandButton btResetSel
      Caption         =   "Reset &Selection"
      Height          =   420
      Left            =   6675
      TabIndex        =   4
      ToolTipText     =   "Remove selection bar"
      Top             =   3405
      Width           =   1320
   End
   Begin VB.Timer tmrCheckTask
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   2385
      Top             =   60
   End
   Begin VB.CheckBox ckKeep
      Alignment       =   1  'Rechts ausgerichtet
      BackColor       =   &H00E8E0E0&
      Caption         =   "&Keep me alive"
      ForeColor       =   &H00008000&
      Height          =   195
      Left            =   9705
      TabIndex        =   2
      ToolTipText     =   "Pop up again after VB terminates"
      Top             =   165
      Value           =   1  'Aktiviert
      Width           =   1320
   End
   Begin VB.CheckBox ckAll
      BackColor       =   &H00E8E0E0&
      ForeColor       =   &H00000000&
      Height          =   240
      Left            =   225
      TabIndex        =   1
      ToolTipText     =   "Select/Unselect all"
      Top             =   135
      Width           =   1605
   End
   Begin VB.ListBox lstRecentProjects
      BackColor       =   &H00F4FBFF&
      ForeColor       =   &H00000000&
      Height          =   2760
      Left            =   180
      Style           =   1  'KontrollkΣstchen
      TabIndex        =   0
      Top             =   495
      Width           =   10830
   End
   Begin VB.CommandButton btRemove
      Caption         =   "&Remove"
      Height          =   420
      Left            =   5220
      TabIndex        =   6
      ToolTipText     =   "Remove checkmarked items from list"
      Top             =   3405
      Width           =   825
   End
   Begin VB.PictureBox picRocket
      BorderStyle     =   0  'Kein
      Height          =   270
      Left            =   9495
      Picture         =   "fRecent.frx":08CA
      ScaleHeight     =   270
      ScaleWidth      =   135
      TabIndex        =   21
      Top             =   3450
      Width           =   135
   End
   Begin VB.Shape shp
      BorderColor     =   &H0000FFFF&
      BorderWidth     =   2
      Height          =   3960
      Left            =   15
      Top             =   15
      Width           =   11205
   End
   Begin VB.Image imgUMG
      Height          =   630
      Left            =   120
      Picture         =   "fRecent.frx":0BE4
      Top             =   3285
      Width           =   675
   End
   Begin VB.Label lbName
      AutoSize        =   -1  'True
      BackColor       =   &H00000000&
      BackStyle       =   0  'Transparent
      Caption         =   "Name:"
      ForeColor       =   &H00606060&
      Height          =   195
      Index           =   1
      Left            =   4470
      TabIndex        =   11
      ToolTipText     =   "Project name"
      Top             =   165
      Visible         =   0   'False
      Width           =   465
   End
   Begin VB.Label lbName
      BackColor       =   &H00000000&
      BackStyle       =   0  'Transparent
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00000000&
      Height          =   195
      Index           =   0
      Left            =   4980
      TabIndex        =   10
      Top             =   165
      Width           =   4485
   End
   Begin VB.Label lbBrokenLinks
      BackColor       =   &H00000000&
      BackStyle       =   0  'Transparent
      Caption         =   "  "
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000000C0&
      Height          =   195
      Left            =   2040
      TabIndex        =   9
      Top             =   165
      Width           =   2130
   End
   Begin VB.Label lb
      BackColor       =   &H00000000&
      BackStyle       =   0  'Transparent
      Caption         =   "Γ"
      BeginProperty Font
         Name            =   "Wingdings"
         Size            =   8.25
         Charset         =   2
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000000C0&
      Height          =   180
      Index           =   4
      Left            =   225
      TabIndex        =   8
      Top             =   345
      Width           =   165
   End
   Begin VB.Label lb
      BackColor       =   &H00000000&
      BackStyle       =   0  'Transparent
      Caption         =   "Checkmark the item(s)  you wish to remove from this list and click  [Remove].  Or select a project and click  [Launch VB6]."
      BeginProperty Font
         Name            =   "Small Fonts"
         Size            =   6.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00606060&
      Height          =   510
      Index           =   3
      Left            =   1035
      TabIndex        =   3
      Top             =   3345
      Width           =   2700
   End
End
Attribute VB_Name = "fRecent"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Private Declare Function CloseHandle Lib "Kernel32" (ByVal hObject 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetLongPathName Lib "Kernel32" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long 'used to get the 'other button'
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function PutFocus Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor 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 ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Private Enum ApiConstants
    CS_DROPSHADOW = &H20000
    GCL_STYLE = -26
    GCL_HCURSOR = -12
    SM_SWAPBUTTON = 23
    CsrArrow = 32512
    CsrRightHand = 32649
    PROCESS_ALL_ACCESS = &H1F0FFF
    SW_SHOWNORMAL = 1
    SE_NO_ERROR = 33 'Values below 33 are error returns
End Enum
#If False Then
Private CS_DROPSHADOW, GCL_STYLE, GCL_HCURSOR, SM_SWAPBUTTON, CsrArrow, CsrRightHand, PROCESS_ALL_ACCESS, SW_SHOWNORMAL, SE_NO_ERROR
#End If

Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type
Private WindowRect   As RECT

Private PrevCursor          As Long
Private Const BurningFileName   As String = "BurningMatch.ani"

Private Enum SortBy
    Chrono = 0
    ByProjName = 1
    ByFileName = 2
End Enum
#If False Then
Private Chrono, ByProjName, ByFileName
#End If
Private SortOpt             As SortBy

Private strCount            As String
Private RecentProjectFile   As String
Private Const RecentFiles   As String = "Software\Microsoft\Visual Basic\6.0\RecentFiles"
Private Const Arrow         As String = " --> "
Private Const Backslash     As String = "\"
Private Const Unknown       As String = "(unknown)"
Private Const GrpNameExt    As String = ".vbg"
Private Const ProjGroup     As String = "[Project Group]"
Private Const Oops          As String = "Ooops..."

Private UndoBuffer()        As Variant
Private UndoPointer         As Long
Private UndoMode            As Boolean

Private lstTopIndex         As Long 'listbox top index
Private Idx                 As Long 'just an index used all over the place
Private hRgn                As Long
Private Internal            As Boolean 'prevents avalanche effects
Private InCheckBox          As Boolean 'true when the user clicks the checkmark in the listbox

Private Enum SortElemMembers
    ProjFileName = 0
    ProjName = 1
    BrokenLink = 2
    OriginalSeq = 3
    PosnInListbox = 4
    PosnInReg = 5
    Expand = 6
End Enum
#If False Then
Private ProjFileName, ProjName, BrokenLink, OriginalSeq, PosnInListbox, PosnInReg, Expand
#End If

Private Enum AnimConsts
    Grow = 1
    Shrink = 2
End Enum
#If False Then
Private Grow, Shrink
#End If

Private Sub Anim(Cntl As Control, ByVal AnimType As AnimConsts)

  Dim DeltaX    As Single
  Dim DeltaY    As Single
  Dim RgnLeft   As Single
  Dim RgnTop    As Single
  Dim RgnRight  As Single
  Dim RgnBottom As Single
  Const Delay   As Long = 900 'times DoEvents seems okay

    Select Case AnimType
      Case Grow, Shrink
        With Cntl
            On Error Resume Next
                hRgn = .hWnd 'find out whether the cntl has an hWnd
                hRgn = Err
            On Error GoTo 0

            If hRgn = 0 Then 'no error - has an hWnd

                RgnRight = ScaleX(.Width, .Parent.ScaleMode, vbPixels) + 1
                RgnBottom = ScaleY(.Height, .Parent.ScaleMode, vbPixels) + 1
                DeltaX = IIf(AnimType = Grow, 1, -1)
                DeltaY = DeltaX * RgnBottom / RgnRight

                If AnimType = Grow Then 'null-region in the center
                    RgnLeft = RgnRight / 2
                    RgnRight = RgnLeft
                    RgnTop = RgnBottom / 2
                    RgnBottom = RgnTop
                  Else 'region is whole control area 'NOT ANIMTYPE...
                    RgnLeft = 0
                    RgnTop = 0
                End If

                Do While .Visible And ((RgnLeft > 0 And AnimType = Grow) Or (RgnLeft < RgnRight And AnimType = Shrink))
                    hRgn = CreateRectRgn(CLng(RgnLeft), CLng(RgnTop), CLng(RgnRight), CLng(RgnBottom))
                    SetWindowRgn .hWnd, hRgn, True
                    DeleteObject hRgn
                    For hRgn = 1 To Delay
                        DoEvents
                    Next hRgn
                    RgnLeft = RgnLeft - DeltaX
                    RgnTop = RgnTop - DeltaY
                    RgnRight = RgnRight + DeltaX
                    RgnBottom = RgnBottom + DeltaY
                Loop

            End If
        End With 'CNTL
    End Select

End Sub

Private Sub btDone_Click()

    Tag = Leave
    Hide

End Sub

Private Sub btDone_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    PutFocus lstRecentProjects.hWnd

End Sub

Private Sub btRemove_Click()

  Dim Renumber  As Long
  Dim t         As Boolean

    With lstRecentProjects
        .Enabled = .ListCount
        If ManuallyAltered Or UndoMode Then
            t = True
          ElseIf .SelCount Then 'NOT MANUALLYALTERED...
            t = (MsgBox("Are you sure you want to remove " & IIf(.ListCount = .SelCount, "ALL", NumToText(.SelCount) & " checkmarked") & " item" & IIf(.SelCount = 1, vbNullString, "s") & " from the Recent Projects List?", vbQuestion Or vbYesNo Or vbDefaultButton2, "Recent Projects") = vbYes)
          Else '.SELCOUNT = FALSE/0
            MsgBox "...you must checkmark the item(s) you wish to remove.", vbInformation, Oops
        End If
        If t Then
            If RegOpenKeyEx(HKEY_CURRENT_USER, RecentFiles, REG_OPTION_RESERVED, KEY_SET_VALUE, KeyHandle) = ERROR_NONE Then

                'delete them all from the registry
                For Idx = 1 To 100
                    strCount = CStr(Idx)
                    RegDeleteValue KeyHandle, strCount
                Next Idx

                If UndoMode Then 'get them from the undo-buffer
                    Idx = 0
                    Do Until IsNull(UndoBuffer(Idx, UndoPointer))
                        ReDim Preserve SortElems(0 To Idx)
                        SortElems(Idx) = UndoBuffer(Idx, UndoPointer)
                        Idx = Idx + 1
                    Loop
                    UndoPointer = UndoPointer - 1
                  Else 'UNDOMODE = FALSE/0
                    UndoPointer = UndoPointer + 1
                    ReDim Preserve UndoBuffer(0 To 100, 1 To UndoPointer) '100th element is for the terminating  null
                    For Idx = 0 To UBound(SortElems)
                        UndoBuffer(Idx, UndoPointer) = SortElems(Idx)
                    Next Idx
                    UndoBuffer(Idx, UndoPointer) = Null 'terminating null
                End If

                QuickSort OriginalSeq 'sort back into original sequence

                'insert the non-checked (or saved-for-undo) items back into the registry
                For Idx = 0 To UBound(SortElems)
                    If UndoMode Then
                        t = True
                      Else 'UNDOMODE = FALSE/0
                        t = Not .Selected(SortElems(Idx)(PosnInListbox))
                    End If
                    If t Then
                        Renumber = Renumber + 1
                        RecentProjectFile = SortElems(Idx)(ProjFileName)
                        strCount = CStr(Renumber)
                        RegSetValueEx KeyHandle, strCount, 0&, REG_SZ, ByVal RecentProjectFile, Len(RecentProjectFile)
                    End If
                Next Idx

                RegCloseKey KeyHandle
                If ManuallyAltered Then
                    Erase UndoBuffer
                    UndoPointer = 0
                End If

                UpdateUnDo
                LoadList '(re)load the listbox
                ProjToOpen = vbNullString 'no project to pass to vb
              Else 'NOT REGOPENKEYEX(HKEY_CURRENT_USER,...
                MsgBox "...cannot locate the recent projects list anymore.", vbCritical, Oops
            End If
        End If

        ManuallyAltered = False
        btRemove.Caption = "&Remove"
        btRemove.ToolTipText = "Remove checkmarked items from list"
        btRunVB6.Enabled = True
        btSave.Enabled = True
        ckAll.Enabled = True
    End With 'LSTRECENTPROJECTS

End Sub

Private Sub btRemove_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    PutFocus lstRecentProjects.hWnd

End Sub

Private Sub btResetSel_Click()

    If btRunVB6.Enabled Or lbName(0) = Unknown Then
        ResetToTop
        ProjToOpen = vbNullString
        lbName(0) = vbNullString
        lbName(1).Visible = False
        btRunVB6.Enabled = True
    End If

End Sub

Private Sub btResetSel_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    lstTopIndex = SendMessage(lstRecentProjects.hWnd, LB_GETTOPINDEX, 0&, ByVal 0&) 'save the TopIndex

End Sub

Private Sub btResetSel_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    PutFocus lstRecentProjects.hWnd

End Sub

Private Sub btRunVB6_Click()

    Tag = RunVB 'return value
    Sleep 300
    Hide 'that's it...

End Sub

Private Sub btRunVB6_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    PutFocus lstRecentProjects.hWnd 'focus off the button

End Sub

Private Sub btSave_Click()

    If btSave.FontBold Then
        ManuallyAltered = True
        btRemove_Click
        btSave.FontBold = False
      Else 'BTSAVE.FONTBOLD = FALSE/0
        MsgBox "...no pathnames have been converted.", vbInformation, Oops
    End If

End Sub

Private Sub btSave_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    PutFocus lstRecentProjects.hWnd

End Sub

Private Sub btUndo_Click()

    If UndoPointer Then
        UndoMode = True
        btRemove_Click
        UndoMode = False
      Else 'UNDOPOINTER = FALSE/0
        MsgBox "...can't undo - the undo buffer is empty, or it is exhausted because" & vbCrLf & _
               "you have already undone all your deletions.", vbInformation, Oops
    End If
    UpdateUnDo

End Sub

Private Sub btUndo_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    PutFocus lstRecentProjects.hWnd

End Sub

Private Sub ckAll_Click()

    If Not Internal Then
        Internal = True 'prevent avalanche
        With lstRecentProjects
            .Visible = False
            lstTopIndex = SendMessage(.hWnd, LB_GETTOPINDEX, 0&, ByVal 0&) 'get top current indec
            For Idx = 0 To .ListCount - 1
                .Selected(Idx) = (ckAll = vbChecked) 'check or uncheck
            Next Idx
            ResetToTop
        End With 'LSTRECENTPROJECTS
        btRemove.FontBold = lstRecentProjects.SelCount
        Internal = False
    End If

End Sub

Private Sub ckAll_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Form_MouseMove 0, 0, 0, 0

End Sub

Private Sub ckKeep_Click()

    PutFocus lstRecentProjects.hWnd 'focus off checkbox

End Sub

Private Sub ckKeep_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Form_MouseMove 0, 0, 0, 0

End Sub

Private Sub ConfineCursorIn(ByVal hWnd As Long)

    GetWindowRect hWnd, WindowRect
    With WindowRect
        .Left = .Left + 1
        .Top = .Top + 1
        .Right = .Right - 1
        .Bottom = .Bottom - 1
    End With 'WINDOWRECT
    ClipCursor WindowRect

End Sub

Private Function ExpandPath(ByVal ShortFilename As String) As String

  'this is here thanks to LaVolpe

  Dim NumChars      As Long

    NumChars = GetLongPathName(ShortFilename, ExpandPath, 0)
    If NumChars Then
        ExpandPath = String$(NumChars, 0)
        ExpandPath = Left$(ExpandPath, GetLongPathName(ShortFilename, ExpandPath, NumChars))
      Else 'NumChars = FALSE/0
        ExpandPath = ShortFilename
    End If

End Function

Private Sub Form_Load()

  Const SnippOff As Long = 4

    Caption = App.ProductName & " V" & Version
    With WindowRect

        .Left = 0
        .Top = 0
        .Right = ScaleX(btRemove.Width, ScaleMode, vbPixels) - SnippOff
        .Bottom = ScaleY(btRemove.Height, ScaleMode, vbPixels)
        hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
        SetWindowRgn btRemove.hWnd, hRgn, True
        DeleteObject hRgn

        .Left = SnippOff
        .Right = ScaleX(btUndo.Width, ScaleMode, vbPixels)
        hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
        SetWindowRgn btUndo.hWnd, hRgn, True
        DeleteObject hRgn

    End With 'WINDOWRECT
    SetClassLong hWnd, GCL_STYLE, GetClassLong(hWnd, GCL_STYLE) Or CS_DROPSHADOW
    lbClose_Click

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Len(ProjToOpen) = 0 Then
        lbName(0) = vbNullString
        lbName(1).Visible = False
        btRunVB6.Enabled = Not ManuallyAltered
    End If
    If Button >= 0 Then
        SetCursor LoadCursor(0, CsrArrow)
    End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

    ClipCursor ByVal 0&

End Sub

Private Sub imgUMG_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    With App
        If Button = vbLeftButton Then
            ShellAbout hWnd, """" & .ProductName & """#Operating System:", .ProductName & " Version " & Version & vbCrLf & App.LegalCopyright, Me.Icon.Handle
          Else 'NOT BUTTON...
            If ShellExecute(hWnd, vbNullString, "mailto:[e-mail]?subject=" & .ProductName & " Version " & Version & " &body=Hi Ulli, " & vbCrLf & "[ MAIL TEXT ] " & vbCrLf & "Best regards from [ SENDER ]", vbNullString, App.Path, SW_SHOWNORMAL) < SE_NO_ERROR Then
                MsgBox "Cannot send Mail from this System.", vbCritical, "Mail disabled/not installed"
            End If
        End If
    End With 'APP

End Sub

Private Sub imgUMG_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  Const LC As String = " LeftClick:"
  Const RC As String = " RightClick:"
  Const AB As String = " About Box "
  Const MA As String = " Mail to Author "
  Const HH As String = "--"

    If GetSystemMetrics(SM_SWAPBUTTON) Then
        imgUMG.ToolTipText = RC & AB & HH & LC & MA
      Else 'GETSYSTEMMETRICS(SM_SWAPBUTTON) = FALSE/0
        imgUMG.ToolTipText = LC & AB & HH & RC & MA
    End If
    Form_MouseMove -1, 0, 0, 0
    SetCursor LoadCursor(0, CsrRightHand)

End Sub

Private Sub lb_Click(Index As Integer)

    Select Case Index
      Case 0 'proj file name
        optFN = True
      Case 1 'proj name
        optPN = True
      Case 2 'chrono
        optCH = True
    End Select

End Sub

Private Sub lb_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

    Form_MouseMove 0, 0, 0, 0

End Sub

Private Sub lbClose_Click()

    Anim picSortBy, Shrink
    picSortBy.Visible = False
    ClipCursor ByVal 0&
    PutFocus lstRecentProjects.hWnd

End Sub

Private Sub lbFire_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If PrevCursor = 0 Then
        PrevCursor = SetClassLong(picFire.hWnd, GCL_HCURSOR, LoadCursorFromFile(App.Path & "\" & BurningFileName))
        ReleaseCapture
        ConfineCursorIn picFire.hWnd
    End If

End Sub

Private Sub lbFire_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  Dim Stepsize    As Long

    If PrevCursor Then
        Sleep 2000
        SetClassLong picFire.hWnd, GCL_HCURSOR, PrevCursor
        PrevCursor = 0
        lbFire.Enabled = False
        ClipCursor ByVal 0&
        Stepsize = ScaleY(1, vbPixels, ScaleMode)
        lbFire.Enabled = False
        With picRocket
            For Idx = 1 To 8
                .Height = .Height + Stepsize
                Sleep 80
                .Refresh
            Next Idx
            For Idx = 1 To 50
                .Top = .Top - Stepsize
                Sleep 10
                DoEvents
            Next Idx
            .Top = ScaleHeight
            Sleep 100
            For Idx = 1 To 37
                .Top = .Top - Stepsize
                Sleep 10
                DoEvents
            Next Idx
            Sleep 333
            For Idx = 1 To 8
                .Height = .Height - Stepsize
                Sleep 80
                DoEvents
            Next Idx
            Sleep 333
        End With 'PICROCKET
        lbFire.Enabled = True

        btRunVB6.Value = btRunVB6.Enabled
    End If

End Sub

Private Sub lbTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    picSortBy_MouseDown Button, Shift, X, Y

End Sub

Public Function LoadList() As Long

  Dim lIdx              As Long
  Dim SeqNum            As Long
  Dim DirLen            As Long
  Dim sSeqNum           As String
  Dim RPF               As String
  Dim Expanded          As Boolean
  Dim hFile             As Long
  Dim Ptr1              As Long
  Dim Ptr2              As Long
  Dim Ptr3              As Long
  Dim Ptr4              As Long
  Dim BrokenSeqPending  As Long
  Dim VBPText           As String

    If RegOpenKeyEx(HKEY_CURRENT_USER, RecentFiles, REG_OPTION_RESERVED, KEY_QUERY_VALUE, KeyHandle) = ERROR_NONE Then
        With lstRecentProjects
            .Clear
            For Idx = 0 To 99
                strCount = CStr(Idx + 1)
                RecentProjectFile = String$(512, 0)
                DataLength = Len(RecentProjectFile)
                If RegQueryValueEx(KeyHandle, strCount, REG_OPTION_RESERVED, DataType, ByVal RecentProjectFile, DataLength) = ERROR_NONE Then
                    sSeqNum = Format$(SeqNum, "000")
                    RPF = Left$(RecentProjectFile, DataLength + (Asc(Mid$(RecentProjectFile, DataLength, 1)) = 0))
                    RecentProjectFile = ExpandPath(RPF)
                    Expanded = Expanded Or (RPF <> RecentProjectFile)
                    ReDim Preserve SortElems(0 To SeqNum)
                    On Error Resume Next
                        DirLen = 0
                        DirLen = Len(Dir$(RecentProjectFile))
                    On Error GoTo 0
                    Select Case True
                      Case DirLen = 0  'broken link
                        SortElems(SeqNum) = Array(RecentProjectFile, Unknown, True, sSeqNum, 0, strCount, False)
                      Case StrComp(Right$(RecentProjectFile, Len(GrpNameExt)), GrpNameExt, vbTextCompare) = 0
                        SortElems(SeqNum) = Array(RecentProjectFile, ProjGroup, False, sSeqNum, 0, strCount, False)
                      Case Else
                        hFile = FreeFile
                        Open RecentProjectFile For Input As hFile
                        VBPText = vbNullString
                        On Error Resume Next
                            VBPText = Input$(LOF(hFile), hFile)
                        On Error GoTo 0
                        Close hFile
                        Ptr1 = InStr(1, VBPText, vbLf & "Name=") + 7
                        If Ptr1 = 7 Then
                            SortElems(SeqNum) = Array(RecentProjectFile, "[Not a Project File]", False, sSeqNum, 0, strCount, (RPF <> RecentProjectFile))
                          Else 'NOT PTR1...
                            Ptr2 = InStr(Ptr1, VBPText, vbCrLf) - 1
                            Ptr3 = InStr(1, VBPText, vbLf & "Description=") + 14
                            If Ptr3 = 14 Then 'no file description
                                Ptr3 = 1
                                Ptr4 = 1
                              Else 'NOT PTR3...
                                Ptr4 = InStr(Ptr3, VBPText, vbCrLf) - 1
                            End If
                            SortElems(SeqNum) = Array(RecentProjectFile, Mid$(VBPText, Ptr1, Ptr2 - Ptr1) & IIf(Ptr3 <> Ptr4, " (" & Mid$(VBPText, Ptr3, Ptr4 - Ptr3) & ")", vbNullString), False, sSeqNum, 0, strCount, (RPF <> RecentProjectFile))
                        End If
                    End Select
                    SeqNum = SeqNum + 1
                    LoadList = BrokenSeqPending 'here comes more after a sequence break
                    btSave.FontBold = Expanded
                  Else 'NOT REGQUERYVALUEEX(KEYHANDLE,...
                    BrokenSeqPending = SeqNum + 1 'maybe this is a break in sequence
                End If
            Next Idx
            RegCloseKey KeyHandle

            If SeqNum Then 'found some entries
                Select Case SortOpt
                  Case ByFileName 'by proj file name
                    QuickSort ProjFileName 'sort on project file name
                  Case ByProjName 'by projname
                    QuickSort ProjName 'sort on project name
                End Select

                lIdx = -1
                For Idx = 0 To UBound(SortElems)
                    Internal = True
                    .AddItem Val(SortElems(Idx)(PosnInReg)) & IIf(SortElems(Idx)(Expand), "+", "") & vbTab & Replace$(SortElems(Idx)(ProjFileName), Backslash, Arrow)
                    SortElems(Idx)(PosnInListbox) = Idx
                    .Selected(Idx) = SortElems(Idx)(BrokenLink)
                    Internal = False
                    If Quote & SortElems(Idx)(ProjFileName) & Quote = ProjToOpen Then
                        lIdx = Idx
                    End If
                Next Idx
            End If
            .Enabled = .ListCount
            If .ListCount Then
                .ListIndex = lIdx 'put (or hide) selection
                If lIdx >= 0 Then
                    lbName(0) = SortElems(lIdx)(ProjName)
                End If
            End If
            ckAll.Caption = "&All  (" & .ListCount & " item" & IIf(.ListCount <> 1, "s)", ")")
            lbBrokenLinks = IIf(.SelCount, "Found " & .SelCount & " broken link" & IIf(.SelCount = 1, vbNullString, "s"), vbNullString)
            lbBrokenLinks.ToolTipText = IIf(.SelCount, " Click [Remove]... ", vbNullString)
            btRemove.FontBold = .SelCount
        End With 'LSTRECENTPROJECTS
      Else 'NOT REGOPENKEYEX(HKEY_CURRENT_USER,...
        MsgBox "...cannot find the recent projects list.", vbCritical, Oops
    End If

End Function

Private Sub lstRecentProjects_Click()

    If Not Internal Then
        With lstRecentProjects
            If InCheckBox Then 'user clicked into checkbox
                ResetToTop
                ProjToOpen = vbNullString 'and no project to pass to vb
                Internal = True 'prevent avalanche effect
                ckAll = IIf(.SelCount = .ListCount, vbChecked, vbUnchecked) 'update all or nothing
                Internal = False
              Else 'not into the checkbox 'INCHECKBOX = FALSE/0
                If .ListIndex >= 0 Then 'user selected a project to pass to vb
                    .Selected(.ListIndex) = False
                    ProjToOpen = Quote & SortElems(.ListIndex)(ProjFileName) & Quote
                    lbName(0) = SortElems(.ListIndex)(ProjName)
                    lbName(1).Visible = True
                    btRunVB6.Enabled = (lbName(0) <> Unknown)
                End If
            End If
            btRemove.FontBold = .SelCount
        End With 'LSTRECENTPROJECTS
    End If

End Sub

Private Sub lstRecentProjects_DblClick()

    btRunVB6 = btRunVB6.Enabled

End Sub

Private Sub lstRecentProjects_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button = vbLeftButton Then
        With lstRecentProjects
            lstTopIndex = SendMessage(.hWnd, LB_GETTOPINDEX, 0&, ByVal 0&) 'save top index
            InCheckBox = (X <= ScaleX(11, vbPixels, ScaleMode)) 'inside the first left 11 pixel
            If Not InCheckBox Then
                .Selected(.ListIndex) = False
            End If
        End With 'LSTRECENTPROJECTS
    End If

End Sub

Private Sub lstRecentProjects_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  Dim Posn      As Long
  Dim FP        As Long
  Const Rows    As Long = 12

    If Len(ProjToOpen) = 0 Then
        FP = ScaleY(4, vbPixels, ScaleMode)
        With lstRecentProjects
            If Y > FP And Y < .Height - FP - FP Then
                Posn = SendMessage(.hWnd, LB_GETTOPINDEX, 0&, ByVal 0&) + (Y - FP) * Rows / (.Height - FP)
                If Posn <= UBound(SortElems) Then
                    lbName(0) = SortElems(Posn)(ProjName)
                    lbName(1).Visible = True
                    btRunVB6.Enabled = (SortElems(Posn)(ProjName) <> Unknown)
                  Else 'NOT POSN...
                    lbName(0) = vbNullString
                    lbName(1).Visible = False
                    btRunVB6.Enabled = True
                End If
            End If
        End With 'LSTRECENTPROJECTS
    End If

End Sub

Private Sub lstRecentProjects_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button = vbRightButton Then
        Select Case SortOpt
          Case ByProjName
            optPN = True
          Case ByFileName
            optFN = True
          Case Chrono 'projname
            optCH = True
        End Select
        With picSortBy
            .Move lstRecentProjects.Left + X - optCH.Left - ScaleX(4, vbPixels, ScaleMode), lstRecentProjects.Top + Y - .Height / 2
            .Visible = True
            DoEvents
            Anim picSortBy, Grow
            ConfineCursorIn .hWnd
        End With 'PICSORTBY
        lbName(0) = vbNullString
        lbName(1).Visible = False
    End If

End Sub

Private Function NumToText(Num As Integer) As String

    If Num < 11 Then
        NumToText = Choose(Num, "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten")
      Else 'NOT NUM...
        NumToText = Num
    End If

End Function

Private Sub optCH_Click()

    SortOpt = Chrono
    ReloadList

End Sub

Private Sub optFN_Click()

    SortOpt = ByFileName
    ReloadList

End Sub

Private Sub optPN_Click()

    SortOpt = ByProjName
    ReloadList

End Sub

Private Sub picSortBy_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button = vbLeftButton Then
        ReleaseCapture 'release the Mouse
        With picSortBy
            SendMessage .hWnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0& 'non-client area button down (in caption)
            ConfineCursorIn .hWnd
        End With 'PICSORTBY
    End If

End Sub

Private Sub ReloadList()

    LoadList
    lbClose_Click

End Sub

Private Sub ResetToTop()

    With lstRecentProjects
        .Visible = False
        .ListIndex = -1 'hide the selection
        SendMessage .hWnd, LB_SETTOPINDEX, lstTopIndex, ByVal 0&
        .Visible = True
        PutFocus .hWnd
    End With 'LSTRECENTPROJECTS

End Sub

Private Sub tmrCheckTask_Timer() 'once per second

  Dim hProcess  As Long

    hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, VBTaskId)
    If hProcess > 0 Then 'we have a process handle so VB is still running
        CloseHandle hProcess 'thats all we wanted to know so close the handle
      Else 'VB has gone 'NOT HPROCESS...
        tmrCheckTask.Enabled = False 'stop the timer
        ckAll = vbUnchecked
        Main '..and here we go again
    End If

End Sub

Private Sub UpdateUnDo()

    With btUndo
        If UndoPointer Then
            .ToolTipText = "Undo last deletion"
            .FontBold = True
          Else 'UNDOPOINTER = FALSE/0
            .ToolTipText = "Can't undo"
            .FontBold = False
        End If
    End With 'BTUNDO

End Sub

Private Function Version() As String

    With App
        Version = .Major & "." & .Minor & "." & .Revision
    End With 'APP

End Function

':) Ulli's VB Code Formatter V2.18.4 (2005-Mrz-30 04:46)  Decl: 97  Code: 767  Total: 864 Lines
':) CommentOnly: 3 (0,3%)  Commented: 89 (10,3%)  Empty: 178 (20,6%)  Max Logic Depth: 8