CD Actual Thematic 25: Programming/pc_actual_25.iso/Basic/GridOne/setup.EXE/CSPECIALFOLDERS.CLS

Visual Basic class definition | 2001-09-09 | 16.9 KB | 612 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CSpecialFolders"
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"
'-----------------------------------------------------------------------------
' This is a part of the BeeGrid ActiveX control.
' Copyright ⌐ 2000 Stinga
' All rights reserved.
'
' You have a right to use and distribute the BeeGrid sample files in original
' form or modified, provided that you agree that Stinga has no warranty,
' obligations, or liability for any sample application files.
'-----------------------------------------------------------------------------
Option Explicit
Implements IModuleInterface
'used by row style condition that
'marks hidden files
Implements IsgConditionTest

Private Const sgGRID_COL_COUNT = 5

Private mImageList As New CSysImageList

Private Type sgtypFileInfo
   Icon As Long
   Name As String * 255
   Size As Single
   FileType As String * 60
   DateCreated As Date
   Attributes As Integer
End Type

Private Type sgtypFetchStatus
   Loaded As Boolean
   LastRow As Long
End Type

Private marFiles() As sgtypFileInfo
Private mFetchStatus As sgtypFetchStatus

Private WithEvents mGrid As SGGrid
Attribute mGrid.VB_VarHelpID = -1
Private msDirectory As String


Private Function CashFiles(ByVal lRowIndex As Long) As Long

   If mFetchStatus.Loaded Then
      If lRowIndex >= mFetchStatus.LastRow Then
         CashFiles = -1
      End If
   Else
      Dim I As Long

      For I = mFetchStatus.LastRow To lRowIndex
         If DoFetchFiles(I) Then
            mFetchStatus.Loaded = True
            mFetchStatus.LastRow = I
            mFetchStatus.Loaded = True
            CashFiles = mFetchStatus.LastRow
            mGrid.MaxRows = I + 1
            Exit Function
         End If
      Next
      mFetchStatus.LastRow = lRowIndex + 1
      CashFiles = mFetchStatus.LastRow
   End If
End Function

Private Function IsPicture(sFileName As String) As Boolean
   Dim sExt As String

   sExt = LCase(Right(sFileName, 3))

   IsPicture = CBool(InStr("gif;bmp;ico;jpg", sExt))
End Function

Private Sub OpenFile(row As SGRow)
   Dim lRowKey As Long
   Dim sFileName As String

   On Error GoTo OpenFileError

   If row.Type <> sgSimpleRow Then Exit Sub

   With mGrid
      lRowKey = row.Key
      sFileName = msDirectory & .cell(lRowKey, "FileName").Value

      If .cell(lRowKey, "Attributes").Value And vbDirectory Then
         'open new directory
         msDirectory = sFileName & "\"
         OpenFolder
      Else
         'open selected file
         ShellExecute .Parent.hwnd, "open", _
            sFileName, "", "", vbNormalFocus
      End If
   End With

   Exit Sub
OpenFileError:
   MsgBox VBA.Error, vbExclamation
   Exit Sub
End Sub

Private Sub OpenFolder()
   Dim I As Long

   With mGrid
      .RedrawEnabled = False

      With .Columns("Icon")
         .ValueItems.RemoveAll
         For I = 1 To mImageList.Count
            .ValueItems.Add I, I, I
         Next
      End With
      ReDim marFiles(1000) As sgtypFileInfo
      mFetchStatus.LastRow = 0
      mFetchStatus.Loaded = False
      mGrid.CellsBorderVisible = False
      .MaxRows = 4194304
      .Groups.RemoveAll
      .DataRowCount = 0
      .RedrawEnabled = True

      .Scroll 3, 0
      .Scroll -3, 0
   End With
End Sub

Private Sub Class_Initialize()
   ReDim marFiles(1000) As sgtypFileInfo
End Sub

Private Function IsgConditionTest_Test _
   (ByVal Value As Variant, ByVal Tag As Variant) As Boolean
   IsgConditionTest_Test = CLng(Value) And vbHidden
End Function

Private Sub mGrid_AfterGroupChange(ByVal Operation As sgGroupOperation, _
   ByVal GroupOrColIndex As Long)
   mGrid.CellsBorderVisible = Not (mGrid.Groups.Count = 0)

   If Operation = sgGroupAdd Then
      With mGrid.Groups(GroupOrColIndex)
         .HeaderTextSource = sgGrpHdrFireFetchText
         .PictureCollapsed = sgGroupHeaderFetchPicture   'sgGroupHeaderPicture
         .PictureExpanded = sgGroupHeaderFetchPicture
      End With
   End If
End Sub




Private Sub mGrid_BeforeGroupChange(ByVal Operation As sgGroupOperation, ByVal GroupOrColIndex As Long, ByVal NewIndex As Long, SortOrder As sgSortOrder, SortType As sgSortType, ShowFooter As Boolean, Cancel As Boolean)
   If Operation = sgGroupAdd Then
      CashFiles 1000000
   End If
End Sub


Private Sub mGrid_FetchCellTip _
   (ByVal RowKey As Long, ByVal ColIndex As Long, _
   ByVal CellKind As sgCellKind, _
   Width As stdole.OLE_XSIZE_CONTAINER, _
   Height As stdole.OLE_YSIZE_CONTAINER, CellTipText As String, _
   Picture As Variant, ByVal TipStyle As IsgStyle)

   If CellKind = sgCellStandard Then
      Dim row As SGRow, ar As SGArray
      Dim lRowData As Long, varFieldSize As Variant
      Dim iColData As Long, sFileName As String

      Set row = mGrid.Rows(RowKey)

      lRowData = row.DataIndex
      If lRowData = -1 Then Exit Sub
      Set ar = mGrid.Array
      iColData = mGrid.Columns("FileName").DBIndex
      sFileName = Trim(ar.Value(lRowData, iColData))
      If IsPicture(sFileName) Then
         On Error Resume Next

         Set Picture = LoadPicture(msDirectory & sFileName)

         If Err = 0 Then
            CellTipText = ""

            With TipStyle
               .AlphaLevel(sgAlphaBackground) = 255
               .Appearance = sg3D
               .BackColor = vbWhite
               .PictureAlignment = sgPicAlignLeftTop
            End With

            Height = Picture.Height ' / 2
            Height = mGrid.Parent.ScaleY _
               (Picture.Height, vbHimetric, mGrid.Parent.ScaleMode)
            Exit Sub
         End If
      End If
      'set picture
      iColData = mGrid.Columns("Icon").DBIndex
      Picture = CLng(ar.Value(lRowData, iColData))
      'set CellTipText
      CellTipText = sFileName
      iColData = mGrid.Columns("FileType").DBIndex
      CellTipText = CellTipText & vbCrLf & ar.Value(lRowData, iColData)

      iColData = mGrid.Columns("FileSize").DBIndex
      varFieldSize = ar.Value(lRowData, iColData)
      iColData = mGrid.Columns("FileSize").ColIndex
      'use code from the FormatText event to format size
      mGrid_FormatText RowKey, iColData, sgCellStandard, varFieldSize
      CellTipText = CellTipText & vbCrLf & "Size: " & varFieldSize
      iColData = mGrid.Columns("DateCreated").DBIndex
      CellTipText = CellTipText & vbCrLf & "Date: " & ar.Value(lRowData, iColData)

      Width = 1600

      Set row = Nothing
   ElseIf CellKind = sgCellGroupHeader Then
      Height = 305
      'use the FetchGroupHeaderData event to set text and picture
      mGrid_FetchGroupHeaderData 1, RowKey, CellTipText, Picture, 0
   Else
      Exit Sub
   End If

   'customize style
   With TipStyle
      .AlphaLevel(sgAlphaBackground) = 255
      .AlphaLevel(sgAlphaBackgroundPicture) = 255
      .Appearance = sg3D
      .BackColor = vbWhite
      .ForeColor = vbBlack
      .WordWrap = True
      .PictureAlignment = sgPicAlignLeftTop
   End With

End Sub

Private Sub mGrid_FetchGroupHeaderData _
   (ByVal GroupIndex As Integer, ByVal RowKey As Long, _
   Text As String, PictureExpanded As Variant, PictureCollapsed As Variant)
   Dim gh As SGGroupHeading
   Dim iIcon As Long, col As SGColumn

   Set gh = mGrid.Rows(RowKey).GroupHeading
   Set col = mGrid.Columns(gh.GroupDef.GroupingColumn)

   Text = " " & col.Caption & ": " & gh.GroupingValue

   If gh.ChildRows.Count > 0 And col.Key = "FileType" Then
      If gh.ChildRows(1).Type = sgSimpleRow Then
         Dim iIconColPos As Integer

         iIconColPos = mGrid.Columns("Icon").Position
         iIcon = CLng(gh.ChildRows(1).Cells(iIconColPos).Value)
         PictureExpanded = iIcon
         PictureCollapsed = iIcon
      End If
   End If

   Set col = Nothing
   Set gh = Nothing
End Sub


Private Sub mGrid_FetchScrollTip(ByVal bar As sgScrollTip, _
   ByVal Index As Variant, Width As stdole.OLE_XSIZE_CONTAINER, _
   Height As stdole.OLE_YSIZE_CONTAINER, ScrollTipText As String, _
   Picture As Variant, ByVal TipStyle As IsgStyle)
   Dim ck As sgCellKind

   ck = mGrid.Rows(Index).Cells(0).Kind


   If ck = sgCellGroupHeader Or ck = sgCellStandard Then
      mGrid_FetchCellTip Index, 1, _
         ck, Width, Height, _
         ScrollTipText, Picture, TipStyle
   Else
      ScrollTipText = ""
   End If
End Sub

Private Sub mGrid_KeyPress(KeyASCII As Integer)
   If KeyASCII = vbKeyReturn Then
      Dim lIndex As Long

      If mGrid.Rows.Current Is Nothing Then Exit Sub

      OpenFile mGrid.Rows.Current
   ElseIf KeyASCII = vbKeyBack Then
      Dim iPos As Integer

      iPos = InStrRev(msDirectory, "\", Len(msDirectory) - 1)

      If iPos = 0 Then Exit Sub

      msDirectory = Left(msDirectory, iPos)

      OpenFolder
   End If
End Sub

Private Function DoFetchFiles(lRowIndex As Long) As Boolean
   Dim sTypeName As String
   Dim sFile As String, lIcon As Long

   On Error GoTo FetchFilesError

   If lRowIndex = 0 Then

      If Len(msDirectory) = 0 Then Exit Function
      sFile = Dir(msDirectory, vbDirectory + vbHidden + vbSystem)

      Do While (sFile = "." Or sFile = "..")
         sFile = Dir
      Loop

   Else
      sFile = Dir
   End If

   If Len(sFile) = 0 Then
      DoFetchFiles = True
      Exit Function
   End If

   lIcon = mImageList.GetIconIndex(msDirectory & sFile, sTypeName)

   marFiles(lRowIndex).Name = sFile
   marFiles(lRowIndex).Size = FileLen(msDirectory & sFile)
   marFiles(lRowIndex).DateCreated = FileDateTime(msDirectory & sFile)
   marFiles(lRowIndex).Icon = lIcon
   marFiles(lRowIndex).FileType = sTypeName
   marFiles(lRowIndex).Attributes = GetAttr(msDirectory & sFile)

   If lRowIndex >= UBound(marFiles) Then _
      ReDim Preserve marFiles(lRowIndex + 500) As sgtypFileInfo

   Exit Function
FetchFilesError:
   '53 file not found
   If Err <> 5 And Err <> 53 Then
      MsgBox VBA.Error, vbExclamation
   End If
   Resume Next
   Resume Next
End Function

Private Sub Class_Terminate()
   Set mGrid = Nothing
   Set mImageList = Nothing
End Sub


Private Property Set IModuleInterface_CellsImageList(ByVal RHS As MSComctlLib.IImageList)

End Property

Private Property Get IModuleInterface_CellsImageList() As MSComctlLib.IImageList

End Property

Private Property Let IModuleInterface_Directory(ByVal RHS As String)
   msDirectory = RHS
End Property

Private Property Get IModuleInterface_Directory() As String
   IModuleInterface_Directory = msDirectory
End Property

Private Property Let IModuleInterface_FolderType(ByVal RHS As Outlook.OlDefaultFolders)

End Property

Private Property Get IModuleInterface_FolderType() As Outlook.OlDefaultFolders

End Property

Private Property Set IModuleInterface_HeadImageList(ByVal RHS As MSComctlLib.IImageList)

End Property

Private Property Get IModuleInterface_HeadImageList() As MSComctlLib.IImageList

End Property

Private Property Let IModuleInterface_Key(ByVal RHS As String)

End Property

Private Property Get IModuleInterface_Key() As String

End Property

Private Property Set IModuleInterface_NameSpace(ByVal RHS As Outlook.NameSpace)

End Property

Private Property Get IModuleInterface_NameSpace() As Outlook.NameSpace

End Property

Private Property Set IModuleInterface_SGGrid(ByVal RHS As IsgGrid)
   Set mGrid = RHS
End Property
Private Property Get IModuleInterface_SGGrid() As IsgGrid
   Set IModuleInterface_SGGrid = mGrid
End Property

Private Sub IModuleInterface_Show()
   Dim I As Integer

   With mGrid
      .RedrawEnabled = False
      .BackColor = vbWhite
      .GroupByBoxVisible = True
      .PreviewPaneType = sgNoPreviewPane
      .Columns.RemoveAll False
      .Images = mImageList.hImageList
      .DataRowCount = 0
      .DefaultRowHeight = 285
      .GridLines = sgGridLineNone
      .CellsBorderVisible = False
      .CellsBorderColor = vbButtonFace
      .AlphaBlendEnabled = True
      .Styles("InactiveSelection").BackColor = vbButtonFace
      .Styles("InactiveSelection").ForeColor = vbBlack
      .EqualRowHeight = True
      .Font.Name = "Tahoma"
      .AutoResize = sgNoAutoResize

      .AllowEdit = False
      .FitLastColumn = True
      .CacheAllRecords = True
      .ColumnClickSort = True
      'selection & drag-and-drop
      .MultiSelect = sgMultiSelectExtended
      .SpecialMode = sgModeListBox
      .OLEDragMode = sgOLEDragModeAutomatic
      'tool tips
      .CellTips = sgCellTipsFloat
      .CellTipsDelay = 500
      .ScrollBarTrack = True
      .ScrollBarTips = sgScrollTipsVertical

      .Columns.RemoveAll True

      With .Columns.Add("Icon")
         .Width = 505
         .Caption = "Icon"
         .Style.DisplayType = sgDisplayPicture
         For I = 1 To mImageList.Count
            .ValueItems.Add I, I, I
         Next
      End With

      With .Columns.Add("FileName")
         .Caption = "File Name"
         .Width = 2400
         .SortType = sgSortTypeCustom
      End With

      With .Columns.Add("FileType")
         .Caption = "File Type"
         .Width = 1400
      End With

      With .Columns.Add("FileSize")
         .Caption = "Size"
         .Style.Format = "FormatText Event"
         .DataType = sgtLong
         .SortType = sgSortTypeNumber
      End With

      With .Columns.Add("DateCreated")
         .Caption = "Date Created"
         .Style.Format = "Short Date"
         .DataType = sgtDateTime
         .SortType = sgSortTypeDateTime
      End With

      With .Columns.Add("Attributes")
         .DataType = sgtLong
         .Hidden = True
      End With

      .DataMode = sgVirtualEvents
      'create sytle condition for hidden files
      With .Styles.Add("HiddenFile")
         .AlphaLevel(sgAlphaContent) = 100
      End With

      .RowStyleConditions.Add "HiddenFile", _
         sgConditionCellValue, sgOpCallback, Me, , "Attributes"

      OpenFolder

      .RedrawEnabled = True
      .Sort -1, -1, "FileName", sgSortAscending, sgSortTypeCustom
   End With
End Sub


Private Sub mGrid_BeforeClickSort _
   (ByVal ColIndex As Long, CancelSort As Boolean)
   Dim col As SGColumn

   CashFiles 1000000

   Set col = mGrid.Columns(ColIndex)

   If col.Key = "FileName" Then
      If col.SortOrder = sgSortAscending Then
         mGrid.Sort -1, -1, "FileName", sgSortDescending, sgSortTypeCustom
      Else
         mGrid.Sort -1, -1, "FileName", sgSortAscending, sgSortTypeCustom
      End If

      CancelSort = True
   End If

   Set col = Nothing
End Sub

Private Sub mGrid_CompareCells(ByVal RowKey1 As Long, _
   ByVal ColIndex1 As Long, ByVal RowKey2 As Long, _
   ByVal ColIndex2 As Long, Result As Integer)
   Dim attr1 As Long, attr2 As Long
   Dim val1 As String, val2 As String

   attr1 = mGrid.cell(RowKey1, "Attributes").Value
   attr2 = mGrid.cell(RowKey2, "Attributes").Value

   If attr1 And vbDirectory Xor attr2 And vbDirectory Then
      Result = IIf(attr1 And vbDirectory, -1, 1)
   Else
      val1 = mGrid.cell(RowKey1, "FileName")
      val2 = mGrid.cell(RowKey2, "FileName")

      Result = IIf(val1 < val2, -1, 1)
   End If
End Sub

Private Sub mGrid_DblClick()

   If mGrid.MouseCol = -1 Or mGrid.MouseRow < 1 Then Exit Sub

   OpenFile mGrid.Rows.At(mGrid.MouseRow)

End Sub

Private Sub mGrid_FormatText(ByVal RowKey As Long, _
   ByVal ColIndex As Long, _
   ByVal CellKind As sgCellKind, Value As Variant)

   If mGrid.Rows.At(0).Key = RowKey Then Exit Sub

   If Value = 0 Then
      Value = ""
   Else
      Dim lTmp As Long
      lTmp = CLng(Value) \ 1024
      If lTmp = 0 Then
         Value = Trim(Value) & " B"
      Else
         Value = Format(lTmp, "#,##0") & " KB"
      End If
   End If
End Sub




Private Sub mGrid_VirtualReadData(ByVal RowBuffer As IsgRowBuffer)
   Dim lRowIndex As Long

   lRowIndex = RowBuffer.rowIndex

   If CashFiles(lRowIndex) = -1 Then
      RowBuffer.rowIndex = -1
      Exit Sub
   End If

   RowBuffer.Value(0) = marFiles(lRowIndex).Icon
   RowBuffer.Value(1) = Trim(marFiles(lRowIndex).Name)
   RowBuffer.Value(2) = Trim(marFiles(lRowIndex).FileType)
   RowBuffer.Value(3) = marFiles(lRowIndex).Size
   RowBuffer.Value(4) = marFiles(lRowIndex).DateCreated
   RowBuffer.Value(5) = marFiles(lRowIndex).Attributes
End Sub