Private Declare Sub CoTaskMemFree Lib "Ole32.dll" (ByVal hMem As Long)
Private Declare Function SHBrowseForFolder Lib "****************l32.dll" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "****************l32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const Max_Path = 260
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Sub Command1_Click()
Dim lIDList As Long
Dim PinCode As String
Dim PathName As String
Dim FileName As String
Dim BrowseInfo As BrowseInfo
With BrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = "Title of Dialog"
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lIDList = SHBrowseForFolder(BrowseInfo)
If Not CBool(lIDList) Then Exit Sub
Call Me.Combo1.Clear
PathName = String(Max_Path, 0)
Call SHGetPathFromIDList(lIDList, PathName)
Call CoTaskMemFree(lIDList)
If CBool(InStr(PathName, vbNullChar)) Then
PathName = Mid(PathName, 1, InStr(PathName, vbNullChar) - 1)
End If
If Not (Right(PathName, 1) = "\") Then PathName = PathName & "\"
FileName = Dir(PathName & "*.*", vbArchive Or vbHidden Or vbReadOnly Or vbSystem)
Do While Len(FileName) > 0
If (LCase(Right(FileName, 4)) = ".txt") Or (LCase(Right(FileName, 4)) = ".vmg") Then
PinCode = GetPinCode(PathName & FileName)
If Len(PinCode) > 0 Then
Call Me.Combo1.AddItem(PinCode & " (" & FileName & ")")
End If
End If
FileName = Dir()
Loop
End Sub
Private Function GetPinCode(ByVal PathName As String) As String
Dim sData As String
Dim hFile As Integer
Dim sTemp As String
hFile = FreeFile
Open PathName For Input As #hFile
On Error Resume Next
sData = Input(LOF(hFile), #hFile)
If Err.Number = 62 Then
Seek #hFile, 1
sData = Input(LOF(hFile) / 2, #hFile)
End If
Close #hFile
On Error GoTo 0
Dim i1Loop As Integer
Dim i2Loop As Integer
Dim Lines() As String
Dim Blocks() As String
Lines = Split(sData, vbNewLine)
For i1Loop = LBound(Lines) To UBound(Lines)
Blocks = Split(Lines(i1Loop), Space(1))
For i2Loop = LBound(Blocks) To UBound(Blocks)
If IsNumeric(Mid(Blocks(i2Loop), 1, 11)) Then
If Mid(Blocks(i2Loop), 12, 1) = "." Then
GetPinCode = Left(Blocks(i2Loop), 11)
End If
End If
Next i2Loop
Next i1Loop
Exit Function
Err:
Select Case Err.Number
Case 62: Return
End Select
End Function
