vbAccelerator - Contents of code file: frmThumbnailExtract.frm

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmThumbnailExtract 
   AutoRedraw      =   -1  'True
   Caption         =   "Shell Thumbnail Extractor Demonstration"
   ClientHeight    =   7335
   ClientLeft      =   2955
   ClientTop       =   2835
   ClientWidth     =   6615
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmThumbnailExtract.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   7335
   ScaleWidth      =   6615
   Begin ComctlLib.ListView lvwThumbNails 
      Height          =   5115
      Left            =   960
      TabIndex        =   3
      Top             =   2160
      Width           =   5535
      _ExtentX        =   9763
      _ExtentY        =   9022
      Arrange         =   1
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   327682
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      Appearance      =   1
      NumItems        =   0
   End
   Begin VB.CommandButton cmdPick 
      Caption         =   "..."
      Height          =   375
      Left            =   6120
      TabIndex        =   2
      Top             =   120
      Width           =   375
   End
   Begin VB.TextBox txtFileName 
      Height          =   375
      Left            =   960
      TabIndex        =   1
      Top             =   120
      Width           =   5115
   End
   Begin ComctlLib.ImageList ilsThumbs 
      Left            =   180
      Top             =   2700
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   100
      ImageHeight     =   100
      MaskColor       =   -2147483643
      _Version        =   327682
   End
   Begin VB.Label lblThumbNails 
      Caption         =   "ThumbNails:"
      Height          =   315
      Left            =   60
      TabIndex        =   4
      Top             =   2160
      Width           =   855
   End
   Begin VB.Label lblFileName 
      Caption         =   "File Name:"
      Height          =   255
      Left            =   60
      TabIndex        =   0
      Top             =   180
      Width           =   855
   End
End
Attribute VB_Name = "frmThumbnailExtract"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' SHAutoComplete:
Private Enum SHAutoCompleteFlags
   SHACF_DEFAULT = &H0                           ' // Currently
    (SHACF_FILESYSTEM | SHACF_URLALL)
   SHACF_FILESYSTEM = &H1                        ' // This includes the File
    System as well as the rest of the shell (Desktop\My Computer\Control Panel\)
   SHACF_URLHISTORY = &H2                        ' // URLs in the User's History
   SHACF_URLMRU = &H4                            ' // URLs in the User's
    Recently Used list.
   SHACF_USETAB = &H8                            ' // Use the tab to move thru
    the autocomplete possibilities instead of to the next dialog/window control.
   SHACF_URLALL = (SHACF_URLHISTORY Or SHACF_URLMRU)
   SHACF_FILESYS_ONLY = &H10                     ' // This includes the File
    System
   SHACF_FILESYS_DIRS = &H20                     ' // Same as
    SHACF_FILESYS_ONLY except it only includes directories, UNC servers, and
    UNC server shares.
   SHACF_AUTOSUGGEST_FORCE_ON = &H10000000       ' // Ignore the registry
    default and force the feature on.
   SHACF_AUTOSUGGEST_FORCE_OFF = &H20000000      ' // Ignore the registry
    default and force the feature off.
   SHACF_AUTOAPPEND_FORCE_ON = &H40000000        ' // Ignore the registry
    default and force the feature on. (Also know as AutoComplete)
   SHACF_AUTOAPPEND_FORCE_OFF = &H80000000       ' // Ignore the registry
    default and force the feature off. (Also know as AutoComplete)
End Enum
Private Declare Function SHAutoComplete Lib "shlwapi.dll" ( _
   ByVal hwndEdit As Long, ByVal dwFlags As Long) As Long

Private m_cThumb As cThumbnailGenerator
Private m_lId As Long

Private Sub cmdPick_Click()
   
   Dim c As New cBrowseForFolder
   c.Title = "Choose Folder or File for thumbnail"
   c.UseNewUI = True
   c.EditBox = True
   c.IncludeFiles = True
   If (txtFileName.Text = "") Then
      c.InitialDir = c.SpecialFolderLocation(CSIDL_DESKTOP)
   Else
      c.InitialDir = txtFileName.Text
   End If
   Dim sSel As String
   sSel = c.BrowseForFolder()
   If (Len(sSel) > 0) Then
      txtFileName.Text = sSel
      showThumbNail
   End If
   
End Sub

Private Sub showThumbNail()
   
   m_cThumb.Filename = txtFileName.Text
   
   On Error GoTo ErrorHandler
   Dim c As pcMemDC
   Set c = m_cThumb.GetThumbnail()
         
   c.PaintPicture Me.hdc, Me.ScaleX(txtFileName.Left, Me.ScaleMode, vbPixels),
    Me.ScaleY(txtFileName.Top + txtFileName.Height, Me.ScaleMode, vbPixels) + 2
   Me.Refresh
   
   m_lId = m_lId + 1
   Dim sKey As String
   sKey = "I" & m_lId
   ilsThumbs.ListImages.Add , sKey, c.Picture
   
   If (lvwThumbNails.ListItems.Count = 0) Then
      Set lvwThumbNails.Icons = ilsThumbs
   End If
   lvwThumbNails.ListItems.Add , sKey, txtFileName.Text, sKey
   lvwThumbNails.Arrange = lvwAutoLeft
   
   Exit Sub

ErrorHandler:
   MsgBox Err.Description, vbExclamation
   Exit Sub
End Sub

Private Sub Form_Load()
   
   On Error Resume Next
   SHAutoComplete txtFileName.hwnd, SHACF_FILESYS_ONLY
   On Error GoTo 0

   Set m_cThumb = New cThumbnailGenerator
   m_cThumb.Options = IEIFLAG_ASPECT Or IEIFLAG_SCREEN
   m_cThumb.DesiredWidth = 96
   m_cThumb.DesiredHeight = 96
   
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   txtFileName.Width = Me.ScaleWidth - txtFileName.Left - cmdPick.Width -
    Me.ScaleX(6, vbPixels, Me.ScaleMode)
   cmdPick.Left = txtFileName.Left + txtFileName.Width + Me.ScaleX(2, vbPixels,
    Me.ScaleMode)
   lvwThumbNails.Width = cmdPick.Left + cmdPick.Width - lvwThumbNails.Left
   lvwThumbNails.Height = Me.ScaleHeight - lvwThumbNails.Top - Me.ScaleY(4,
    vbPixels, Me.ScaleMode)
End Sub

Private Sub txtFileName_KeyDown(KeyCode As Integer, Shift As Integer)
   If (KeyCode = vbKeyReturn) Then
      showThumbNail
   End If
End Sub