home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / Disk_Data_2224916142012.psc / clsBrowse.cls < prev    next >
Text File  |  2012-06-14  |  14KB  |  326 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cBrowse"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
  15. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  16. ' ***************************************************************************
  17. ' Module:        clsBrowse
  18. '
  19. ' Description:   This class is used to browse for a folder and other generic
  20. '                routines
  21. '
  22. ' Important:      This module must have access to modTrimStr.bas
  23. '
  24. ' ===========================================================================
  25. '    DATE      NAME / DESCRIPTION
  26. ' -----------  --------------------------------------------------------------
  27. ' 14-MAY-2002  Kenneth Ives  kenaso@tx.rr.com
  28. '              Wrote class
  29. ' 01-Nov-2008  Kenneth Ives  kenaso@tx.rr.com
  30. '              Created flag BIF_FOLDERSONLY to display folder selection
  31. '              window regardless of Windows version.
  32. ' 26-Mar-2012  Kenneth Ives  kenaso@tx.rr.com
  33. '              - Deleted RemoveTrailingNulls() routine from this module. 
  34. '              - Changed call to RemoveTrailingNulls() to TrimStr module 
  35. '                due to speed and accuracy.
  36. ' ***************************************************************************
  37. Option Explicit
  38.  
  39. ' ***************************************************************************
  40. ' Constants - Miscellaneous
  41. ' ***************************************************************************
  42.   Private Const MODULE_NAME           As String = "clsBrowse"
  43.   Private Const DEFAULT_TITLE         As String = "Browse for a folder"
  44.   Private Const MAX_SIZE              As Long = 260
  45.  
  46. ' ***************************************************************************
  47. ' Constants used for Coloring progress bar
  48. ' ***************************************************************************
  49.   Private Const WM_USER               As Long = &H400
  50.   Private Const CCM_FIRST             As Long = &H2000&
  51.   Private Const CCM_SETBKCOLOR        As Long = (CCM_FIRST + 1)
  52.   Private Const PBM_SETBKCOLOR        As Long = CCM_SETBKCOLOR
  53.   Private Const PBM_SETBARCOLOR       As Long = (WM_USER + 9)
  54.  
  55. ' ***************************************************************************
  56. ' Constants used for browsing for a folder
  57. ' ***************************************************************************
  58.   Private Const BIF_RETURNONLYFSDIRS  As Long = &H1&      ' only file system directories
  59.   Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2&      ' no network folders below domain level
  60.   Private Const BIF_STATUSTEXT        As Long = &H4&      ' include status area for callback
  61.   Private Const BIF_RETURNFSANCESTORS As Long = &H8&      ' only return file system ancestors
  62.   Private Const BIF_NEWDIALOGSTYLE    As Long = &H40&     ' use the new dialog layout
  63.   Private Const BIF_NONEWFOLDERBUTTON As Long = &H200&
  64.   Private Const BIF_FOLDERSONLY       As Long = BIF_RETURNONLYFSDIRS Or _
  65.                                                 BIF_DONTGOBELOWDOMAIN Or _
  66.                                                 BIF_STATUSTEXT Or _
  67.                                                 BIF_RETURNFSANCESTORS Or _
  68.                                                 BIF_NEWDIALOGSTYLE Or _
  69.                                                 BIF_NONEWFOLDERBUTTON
  70.  
  71. ' ***************************************************************************
  72. ' Type structures used for browsing for a folder
  73. ' ***************************************************************************
  74.   ' Contains parameters for the SHBrowseForFolder function and receives
  75.   ' information about the folder selected by the user.
  76.   Private Type BROWSEINFO
  77.       hOwner         As Long
  78.       pidlRoot       As Long
  79.       pszDisplayName As String
  80.       lpszTitle      As String
  81.       ulFlags        As Long
  82.       lpfn           As Long
  83.       lParam         As Long
  84.       iImage         As Long
  85.   End Type
  86.  
  87. ' ***************************************************************************
  88. ' API Declares used for changing color of a progress bar
  89. ' ***************************************************************************
  90.   ' The SendMessage function sends the specified message to a window or
  91.   ' windows. The function calls the window procedure for the specified
  92.   ' window and does not return until the window procedure has processed
  93.   ' the message.
  94.   Private Declare Function SendMessage Lib "user32" _
  95.           Alias "SendMessageA" _
  96.           (ByVal hwnd As Long, ByVal wMsg As Long, _
  97.           ByVal wParam As Long, lParam As Any) As Long
  98.  
  99. ' ***************************************************************************
  100. ' API Declares used for browsing for a folder
  101. ' ***************************************************************************
  102.   ' Converts an item identifier list to a file system path.
  103.   Private Declare Function SHGetPathFromIDList Lib "shell32" _
  104.           Alias "SHGetPathFromIDListA" _
  105.           (ByVal pidl As Long, ByVal pszPath As String) As Long
  106.  
  107.   ' Displays a dialog box that enables the user to select a shell folder.
  108.   Private Declare Function SHBrowseForFolder Lib "shell32" _
  109.           Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  110.  
  111.   ' Frees a block of task memory previously allocated through a call
  112.   ' to the CoTaskMemAlloc or CoTaskMemRealloc function.
  113.   Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
  114.  
  115.   ' Truncates a path to fit within a certain number of characters by replacing
  116.   ' path components with ellipses.
  117.   Private Declare Function PathCompactPathEx Lib "shlwapi.dll" _
  118.           Alias "PathCompactPathExA" _
  119.           (ByVal pszOut As String, ByVal pszSrc As String, _
  120.           ByVal cchMax As Long, ByVal dwFlags As Long) As Long
  121.  
  122.  
  123. ' ***************************************************************************
  124. ' ****                      Methods                                      ****
  125. ' ***************************************************************************
  126.  
  127. ' ***************************************************************************
  128. ' Routine:       BrowseForFolder
  129. '
  130. ' Description:   This function will open the folder browse dialog box.
  131. '
  132. ' Parameters:    frm - Form that is calling this routine
  133. '                strTitle - [Optional] Title to be displayed on the dialog
  134. '                      box.  Uses default title if none is provided.
  135. '
  136. ' Returns:       Name of folder selected.
  137. '
  138. ' ===========================================================================
  139. '    DATE      NAME / DESCRIPTION
  140. ' -----------  --------------------------------------------------------------
  141. ' Unknown      Randy Birch http://www.mvps.org/vbnet/index.html
  142. '              Original routine
  143. ' 14-MAY-2002  Kenneth Ives  kenaso@tx.rr.com
  144. '              Modified/documented
  145. ' 01-Nov-2008  Kenneth Ives  kenaso@tx.rr.com
  146. '              Added new flag BIF_FOLDERSONLY to display folder selection
  147. '              window regardless of Windows version.
  148. ' ***************************************************************************
  149. Public Function BrowseForFolder(ByRef frm As Form, _
  150.                        Optional ByVal strTitle As String = DEFAULT_TITLE) As String
  151. Attribute BrowseForFolder.VB_Description = "Shutdown the operating system."
  152.  
  153.     Dim typBI         As BROWSEINFO
  154.     Dim strPath       As String
  155.     Dim lngPathHandle As Long
  156.  
  157.     On Error GoTo BrowseForFolder_Error
  158.     
  159.     With typBI
  160.         ' Hwnd of the window that receives messages from the call. Can be your
  161.         ' application or the handle from GetDesktopWindow().
  162.         .hOwner = frm.hwnd
  163.     
  164.         ' Pointer to the item identifier list specifying the location of the "root"
  165.         ' folder to browse from.  If NULL, the desktop folder is used.
  166.         .pidlRoot = 0&
  167.     
  168.         .lpszTitle = strTitle       ' message to be displayed in the Browse dialog
  169.         .ulFlags = BIF_FOLDERSONLY  ' the type of folder to return
  170.     End With
  171.     
  172.     lngPathHandle = SHBrowseForFolder(typBI) ' show the browse for folders dialog
  173.  
  174.     ' the dialog has closed, so parse & display the user's returned folder
  175.     ' selection contained in lngPathHandle
  176.     strPath = Space$(MAX_SIZE)
  177.  
  178.     ' Remove all trailing nulls from the folder selected
  179.     If SHGetPathFromIDList(ByVal lngPathHandle, ByVal strPath) Then
  180.         strPath = TrimStr(strPath)
  181.     Else
  182.         strPath = vbNullString
  183.     End If
  184.  
  185. BrowseForFolder_CleanUp:
  186.     ' Always close any open handles when not in use
  187.     CoTaskMemFree lngPathHandle
  188.     BrowseForFolder = strPath
  189.     On Error GoTo 0
  190.     Exit Function
  191.  
  192. BrowseForFolder_Error:
  193.     ErrorMsg MODULE_NAME, "BrowseForFolder", Err.Description
  194.     strPath = vbNullString
  195.     Resume BrowseForFolder_CleanUp
  196.  
  197. End Function
  198.  
  199. ' ***************************************************************************
  200. ' Routine:       ShrinkToFit
  201. '
  202. ' Description:   This routine creates the ellipsed string by specifying
  203. '                the size of the desired string in characters.  Adds
  204. '                ellipses to a file path whose maximum length is specified
  205. '                in characters.
  206. '
  207. ' Parameters:    strPath - Path to be resized for display
  208. '                intMaxLength - Maximum length of the return string
  209. '
  210. ' Returns:       Resized path
  211. '
  212. ' ===========================================================================
  213. '    DATE      NAME / DESCRIPTION
  214. ' -----------  --------------------------------------------------------------
  215. ' 20-May-2004  Randy Birch
  216. '              http://vbnet.mvps.org/code/fileapi/pathcompactpathex.htm
  217. ' 22-Jun-2004  Kenneth Ives  kenaso@tx.rr.com
  218. '              Modified/documented
  219. ' ***************************************************************************
  220. Public Function ShrinkToFit(ByVal strPath As String, _
  221.                             ByVal intMaxLength As Integer) As String
  222.  
  223.     Dim strBuffer As String
  224.     
  225.     strPath = TrimStr(strPath)
  226.     
  227.     ' See if ellipses need to be inserted into the path
  228.     If Len(strPath) <= intMaxLength Then
  229.         ShrinkToFit = strPath
  230.         Exit Function
  231.     End If
  232.     
  233.     ' intMaxLength is the maximum number of characters to be contained in the
  234.     ' new string, **including the terminating NULL character**. For example,
  235.     ' if intMaxLength = 8, the resulting string would contain a maximum of
  236.     ' seven characters plus the termnating null.
  237.     '
  238.     ' Because of this, one has been added to the value passed as intMaxLength
  239.     ' to ensure the resulting string is the size requested.
  240.     intMaxLength = intMaxLength + 1
  241.     strBuffer = Space$(MAX_SIZE)
  242.     PathCompactPathEx strBuffer, strPath, intMaxLength, 0&
  243.     
  244.     ' Return the readjusted data string
  245.     ShrinkToFit = TrimStr(strBuffer)
  246.     
  247. End Function
  248.  
  249. ' ***************************************************************************
  250. ' Routine:       SetPBarForegroundColor
  251. '
  252. ' Description:   Set the Microsoft progress bar progression color
  253. '
  254. ' Parameters:    lngPBarHwnd - Handle designating the progress bar
  255. '                lngColor - long integer representing the color desired
  256. '
  257. ' ===========================================================================
  258. '    DATE      NAME / DESCRIPTION
  259. ' -----------  --------------------------------------------------------------
  260. ' Unknown      Randy Birch http://www.mvps.org/vbnet/index.html
  261. '              Original routine
  262. ' 14-MAY-2002  Kenneth Ives  kenaso@tx.rr.com
  263. '              Modified/documented
  264. ' ***************************************************************************
  265. Public Sub SetPBarForegroundColor(ByRef lngPBarHwnd As Long, _
  266.                                   ByVal lngColor As Long)
  267.  
  268.     On Error GoTo SetPBarForegroundColor_Error
  269.  
  270.     ' Change progress color
  271.     '
  272.     ' Syntax:
  273.     '   SetPBarForegroundColor ProgressBar.hwnd, RGB(205, 0, 0)  ' red
  274.     SendMessage lngPBarHwnd, PBM_SETBARCOLOR, 0&, ByVal lngColor
  275.  
  276. SetPBarForegroundColor_CleanUp:
  277.     On Error GoTo 0
  278.     Exit Sub
  279.  
  280. SetPBarForegroundColor_Error:
  281.     ErrorMsg MODULE_NAME, "SetPBarForegroundColor", Err.Description
  282.     Resume SetPBarForegroundColor_CleanUp
  283.  
  284. End Sub
  285.  
  286. ' ***************************************************************************
  287. ' Routine:       SetPBarBackgroundColor
  288. '
  289. ' Description:   Set the Microsoft progress bar background color
  290. '
  291. ' Parameters:    lngPBarHwnd - Handle designating the progress bar
  292. '                lngColor - long integer representing the color desired
  293. '
  294. ' ===========================================================================
  295. '    DATE      NAME / DESCRIPTION
  296. ' -----------  --------------------------------------------------------------
  297. ' Unknown      Randy Birch http://www.mvps.org/vbnet/index.html
  298. '              Original routine
  299. ' 14-MAY-2002  Kenneth Ives  kenaso@tx.rr.com
  300. '              Modified/documented
  301. ' ***************************************************************************
  302. Public Sub SetPBarBackgroundColor(ByRef lngPBarHwnd As Long, _
  303.                                   ByVal lngColor As Long)
  304.  
  305.     On Error GoTo SetPBarBackgroundColor_Error
  306.  
  307.     ' Change background color
  308.     '
  309.     ' With CommonDialog1
  310.     '      .CancelError = True
  311.     '      .ShowColor
  312.     '      SetPBarBackgroundColor ProgressBar.hwnd, .Color
  313.     ' End With
  314.     SendMessage lngPBarHwnd, PBM_SETBKCOLOR, 0&, ByVal lngColor
  315.  
  316. SetPBarBackgroundColor_CleanUp:
  317.     On Error GoTo 0
  318.     Exit Sub
  319.  
  320. SetPBarBackgroundColor_Error:
  321.     ErrorMsg MODULE_NAME, "SetPBarBackgroundColor", Err.Description
  322.     Resume SetPBarBackgroundColor_CleanUp
  323.  
  324. End Sub
  325.  
  326.