Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/popupx/setup.exe/_SETUP.1/frmSample.frm

Visual Basic Form | 1998-07-01 | 11.1 KB | 299 lines

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.2#0"; "COMCTL32.OCX"
Object = "{D3732FCB-1082-11D2-AB9F-000000000000}#1.0#0"; "PopupX-Trial.ocx"
Begin VB.Form frmSample
   AutoRedraw      =   -1  'True
   BackColor       =   &H80000001&
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   375
   ClientLeft      =   15
   ClientTop       =   15
   ClientWidth     =   4680
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   375
   ScaleWidth      =   4680
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin PopupX_Evaluation.PopupMenu PopupMenu1
      Left            =   2040
      Top             =   90
      _ExtentX        =   847
      _ExtentY        =   847
      ParentHwnd      =   4056
   End
   Begin VB.CommandButton Command1
      Height          =   315
      Left            =   30
      Picture         =   "frmSample.frx":0000
      Style           =   1  'Graphical
      TabIndex        =   1
      Top             =   30
      UseMaskColor    =   -1  'True
      Width           =   855
   End
   Begin ComctlLib.StatusBar StatusBar1
      Align           =   2  'Align Bottom
      Height          =   375
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   4680
      _ExtentX        =   8255
      _ExtentY        =   661
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7}
         NumPanels       =   2
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7}
            AutoSize        =   1
            Bevel           =   0
            Object.Width           =   5556
            TextSave        =   ""
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7}
            Style           =   5
            Alignment       =   1
            AutoSize        =   2
            Object.Width           =   2619
            Picture         =   "frmSample.frx":0296
            TextSave        =   "1:38 AM"
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
      EndProperty
   End
Attribute VB_Name = "frmSample"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Text
Option Explicit
Dim WFD As WIN32_FIND_DATA, hItem&, hFile&
Dim fileCount&, fileCount1&, TotalFiles%, Running%, hLB&, FileSpec$, UseFileSpec%
Const vbBackslash = "\"
Const vbAllFiles = "*.*"
Const vbKeyDot = 46
Dim currdir() As String
Dim currdir1() As String
Dim ActiveMenu As String
Private Const HWND_TOPMOST = -1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOREPOSITION = &H200
Private Const SWP_NOSIZE = &H1
Private Sub Command1_Click()
    ActiveMenu = "Browse"
    PopupMenu1.ShowPopupMenu "Browse", ScaleX(Command1.Left, vbTwips, vbPixels), ScaleY(Command1.Top, vbTwips, vbPixels)
End Sub
Private Sub Form_Load()
Move 0, Screen.Height - Height, Screen.Width
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE
PopupMenu1.Enabled = True
End Sub
Private Function addDrives()
'Retrieves Local Drives and adds them to the POPUPMENU
Dim drvbitmask&, maxpwr%, pwr%
drvbitmask& = GetLogicalDrives()
    ' If GetLogicalDrives() succeeds, the return value is a bitmask representing
    ' the currently available disk drives. Bit position 0 (the least-significant bit)
    ' is drive A, bit position 1 is drive B, bit position 2 is drive C, and so on.
    ' If the function fails, the return value is zero.
    ' GetLogicalDriveStrings() could be used here instead,
    ' but it's string buffer would have to be parsed...
    If drvbitmask& Then
        ' Get & search each available drive
        maxpwr% = Int(Log(drvbitmask&) / Log(2))   ' a little math...
        For pwr% = 2 To maxpwr%
            If (2 ^ pwr% And drvbitmask&) Then _
                'test if drive has at least one file in root dir
                hItem& = FindFirstFile((Chr$(vbKeyA + pwr%) & ":\") & vbAllFiles, WFD)
                If hItem& <> INVALID_HANDLE_VALUE Then
                    'drive contains at least one file... so we will display a submenu
                    PopupMenu1.AppendMenu (Chr$(vbKeyA + pwr%)), (Chr$(vbKeyA + pwr%) & ":\"), True
                Else
                    'drive does not contain files or is inaccessible... so we will just display the drive letter
                    PopupMenu1.AppendMenu (Chr$(vbKeyA + pwr%)), (Chr$(vbKeyA + pwr%) & ":\")
                End If
            End If
        Next
    End If
End Function
Private Function addDirs(curpath$)  ' curpath$ is passed w/ trailing "\"
    If Right(curpath, 1) <> "\" Then curpath = curpath & "\"
    Dim i%
    fileCount = 0
    fileCount1 = 0
    ReDim currdir(1, 10) As String
    ReDim currdir1(1, 10) As String
    '''''If Not Running% Then Exit Function
    ' This loop finds *every* subdir and file in the current dir
    hItem& = FindFirstFile(curpath$ & vbAllFiles, WFD)
    If hItem& <> INVALID_HANDLE_VALUE Then

        Do
            ' Tests for subdirs only...
            If (WFD.dwFileAttributes And vbDirectory) Then

                ' If not a  "." or ".." DOS subdir...
                If Asc(WFD.cFileName) <> vbKeyDot Then
                    ' This is executed in the mnuFindFiles_Click()
                    ' call though it isn't used...
                    'TotalDirs% = TotalDirs% + 1
                    ' This is the heart of a recursive proc...
                    ' Cache the subdirs of the current dir in the 1 based array.
                    ' This proc calls itself below for each subdir cached in the array.
                    ' (re-allocating the array only once every 10 itinerations improves speed)
                    If (fileCount Mod 10) = 0 Then ReDim Preserve currdir(1, fileCount + 10)
                    currdir(0, fileCount) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
                    currdir(1, fileCount) = -1
                    fileCount = fileCount + 1
                End If

            ' File size and attribute tests can be used here, i.e:
            ' ElseIf (WFD.dwFileAttributes And vbHidden) = False Then  'etc...

            ' Get a total file count for mnuFolderInfo_Click()
            ElseIf Not UseFileSpec% Then
            If (fileCount1 Mod 10) = 0 Then ReDim Preserve currdir1(1, fileCount1 + 10)
            currdir1(0, fileCount1) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
            currdir1(1, fileCount1) = 0
 '           PopupMenu1.AppendMenu WFD.cFileName, curpath$ & WFD.cFileName
            fileCount1 = fileCount1 + 1
            End If

        ' Get the next subdir or file

        Loop While FindNextFile(hItem&, WFD)

        ' Close the search handle
        Call FindClose(hItem&)
    End If
 QuickSort 0, fileCount - 1
 QuickSort1 0, fileCount1 - 1
On Error GoTo erradddirs
For i = 0 To fileCount - 1
    PopupMenu1.AppendMenu currdir(0, i), curpath & currdir(0, i), Val(currdir(1, i))
Next i
For i = 0 To fileCount1 - 1
    PopupMenu1.AppendMenu currdir1(0, i), curpath & currdir1(0, i), Val(currdir1(1, i))
Next i
Exit Function
erradddirs:
MsgBox Error
End Function
Private Function QuickSort(First&, ByVal Last&) As Boolean
If Last < 1 Then Exit Function
Dim Switch As Boolean
Dim BuffArray(1, 1) As String
Dim RemFirst&, RemLast&, p&
Dim i As Long
RemFirst = First
RemLast = Last
p = First
    Switch = False
    Do While Switch = False And p < Last
        If currdir(0, p) > currdir(0, Last) Then
            For i = 0 To 1
                BuffArray(i, 1) = currdir(i, p)
                currdir(i, p) = currdir(i, Last)
                currdir(i, Last) = BuffArray(i, 1)
            Next i
            First = First + 1
            p = Last
            Switch = True
        End If
    If Switch = False Then Last = Last - 1
    Loop
    Switch = False
    Do While Switch = False And p > First
        If currdir(0, p) < currdir(0, First) Then
            For i = 0 To 1
                BuffArray(i, 1) = currdir(i, p)
                currdir(i, p) = currdir(i, First)
                currdir(i, First) = BuffArray(i, 1)
            Next i
            Last = Last - 1
            p = First
            Switch = True
        End If
        If Switch = False Then First = First + 1
    Loop
Loop Until First = p And Last = p
If p - RemFirst > 1 Then QuickSort RemFirst, p - 1
If RemLast - p > 1 Then QuickSort p + 1, RemLast
End Function
Private Function QuickSort1(First&, ByVal Last&) As Boolean
If Last < 1 Then Exit Function
Dim Switch As Boolean
Dim BuffArray(1, 1) As String
Dim RemFirst&, RemLast&, p&
Dim i As Long
RemFirst = First
RemLast = Last
p = First
    Switch = False
    Do While Switch = False And p < Last
        If currdir1(0, p) > currdir1(0, Last) Then
            For i = 0 To 1
                BuffArray(i, 1) = currdir1(i, p)
                currdir1(i, p) = currdir1(i, Last)
                currdir1(i, Last) = BuffArray(i, 1)
            Next i
            First = First + 1
            p = Last
            Switch = True
        End If
    If Switch = False Then Last = Last - 1
    Loop
    Switch = False
    Do While Switch = False And p > First
        If currdir1(0, p) < currdir1(0, First) Then
            For i = 0 To 1
                BuffArray(i, 1) = currdir1(i, p)
                currdir1(i, p) = currdir1(i, First)
                currdir1(i, First) = BuffArray(i, 1)
            Next i
            Last = Last - 1
            p = First
            Switch = True
        End If
        If Switch = False Then First = First + 1
    Loop
Loop Until First = p And Last = p
If p - RemFirst > 1 Then QuickSort1 RemFirst, p - 1
If RemLast - p > 1 Then QuickSort1 p + 1, RemLast
End Function
Private Sub PopupMenu1_GetMenuContent(ActiveMenu As String, Caption As String, ItemData As String)
Dim Waitcurs As CWaitCursor
Set Waitcurs = New CWaitCursor
Waitcurs.SetCursor
'Debug.Print Key
'Debug.Print itemvalue
Select Case ActiveMenu
Case "Browse"
If ItemData = "" Then
    addDrives
    PopupMenu1.AppendMenu "-"
    PopupMenu1.AppendMenu "&Quit", "-1"
    addDirs (ItemData)
End If
End Select
End Sub
Private Sub PopupMenu1_MenuClick(ActiveMenu As String, Caption As String, ItemData As String)
If ItemData = "-1" Then
    Unload Me
    Dim retval As Long
    retval = Module1.ShellExecute(hwnd, "open", ItemData & Chr(0), vbNull, vbNull, 5)

End If
End Sub