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