home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Common_DLG628003172002.psc / modFileDir.bas < prev   
Encoding:
BASIC Source File  |  2002-03-17  |  2.9 KB  |  84 lines
  1. Attribute VB_Name = "modFileDir"
  2. Public fs As New FileSystemObject
  3. Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  4. Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
  5. Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
  6. Const HKEY_CURRENT_USER = &H80000001
  7. Global Path As String
  8.  
  9. Sub ShowFolderList(FolderSpec, ByRef FolderList() As String)
  10.     On Error Resume Next
  11.     Dim f As Folder, f1 As Folder, fc, i As Long
  12.     Set f = fs.GetFolder(FolderSpec)
  13.     Set fc = f.SubFolders
  14.     For Each f1 In fc
  15.         i = i + 1
  16.         ReDim Preserve FolderList(i)
  17.         FolderList(i) = f1.Name
  18.     Next
  19. End Sub
  20.  
  21. Sub ShowFileList(FolderSpec, ByRef FileList() As String)
  22.     On Error Resume Next
  23.     Dim f As Folder, f1 As File, fc As Files, i As Long
  24.     Set f = fs.GetFolder(FolderSpec)
  25.     Set fc = f.Files
  26.     For Each f1 In fc
  27.         i = i + 1
  28.         ReDim Preserve FileList(i)
  29.         FileList(i) = f1.Name
  30.     Next
  31. End Sub
  32.  
  33. Public Function GetSettingString(hKey As Long, strPath As String, strValue As String) As String
  34.     Dim hCurKey As Long
  35.     Dim lngDataBufferSize As Long
  36.     Dim lngValueType As Long
  37.     Dim strBuffer As String
  38.     apiError = RegOpenKeyEx(hKey, strPath, 0, &H1, hCurKey)
  39.     If Not apiError = 0 Then
  40.         Exit Function
  41.     End If
  42.     apiError = RegQueryValueEx(hCurKey, strValue & Chr$(0), 0&, lngValueType, ByVal 0&, lngDataBufferSize)
  43.     If lngValueType = 1 Then
  44.         strBuffer = Space$(lngDataBufferSize)
  45.         apiError = RegQueryValueEx(hCurKey, strValue & Chr$(0), 0&, 0&, ByVal strBuffer, lngDataBufferSize)
  46.         GetSettingString = Fix_NullTermStr(strBuffer)
  47.     End If
  48.     apiError = RegCloseKey(hCurKey)
  49. End Function
  50.  
  51. Public Function Fix_NullTermStr(strData As String) As String
  52.     If strData = "" Then Exit Function
  53.     If InStr(1, strData, Chr$(0)) = 0 Then
  54.         Exit Function
  55.     Else
  56.         Fix_NullTermStr = Left$(strData, InStr(1, strData, Chr$(0)) - 1) '-1 for removing null also
  57.     End If
  58. End Function
  59.  
  60. Public Function Word(ByVal sSource As String, n As Long, SP As String) As String
  61. Dim pointer As Long
  62. Dim pos As Long
  63. Dim x As Long
  64. Dim lEnd As Long
  65. On Error Resume Next
  66. x = 1
  67. pointer = 1
  68. Do
  69.    Do While Mid$(sSource, pointer, 1) = SP
  70.       pointer = pointer + 1
  71.    Loop
  72.    If x = n Then
  73.       lEnd = InStr(pointer, sSource, SP)
  74.       If lEnd = 0 Then lEnd = Len(sSource) + 1
  75.       Word = Mid$(sSource, pointer, lEnd - pointer)
  76.       Exit Do
  77.    End If
  78.    pos = InStr(pointer, sSource, SP)
  79.    If pos = 0 Then Exit Do
  80.    x = x + 1
  81.    pointer = pos + 1
  82. Loop
  83. End Function
  84.