Nhờ test giúp code (lấy tất cả các đuôi file + kiểm tra chương trình chạy của nó) (1 người xem)

[anhtuan1066]

Tôi có 1 đoạn code dùng để lấy toàn bộ các đuôi file trên máy tính (file extension) và kiểm tra xem chương trình nào chạy mỗi 1 đuôi file ấy
Máy tôi cài Win7 + Office 2010 chạy tốt nhưng không biết trên Windows XP thì thế nào
Code như sau:

Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
  (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long

Function GetTempFile(ByVal Extension As String) As String
  Dim tmpFolder As String, tmpFile As String, tmpExt As String
  Extension = Replace(Extension, ".", "")
  With CreateObject("Scripting.FileSystemObject")
    tmpFolder = .GetSpecialFolder(2).Path
    tmpFile = .BuildPath(tmpFolder, .GetTempName)
    tmpExt = .GetExtensionName(tmpFile)
    tmpFile = Left(tmpFile, Len(tmpFile) - Len(tmpExt)) & Extension
    .CreateTextFile tmpFile, True
    GetTempFile = tmpFile
  End With
End Function

Function GetAssociatedProgram(ByVal Extension As String) As String
  Dim assProg As String, tmpFile As String, p1 As String, p2 As String
  On Error Resume Next
  Extension = Replace(Extension, ".", "")
  tmpFile = GetTempFile(Extension)
  assProg = Space$(1024)
  With CreateObject("Scripting.FileSystemObject")
    FindExecutable tmpFile, "", assProg
    p1 = UCase(.GetFile(tmpFile).ParentFolder.Path)
    p2 = UCase(.GetFile(assProg).ParentFolder.Path)
    If p1 <> p2 Then GetAssociatedProgram = Left(assProg, InStr(assProg, Chr(0)) - 1)
    .DeleteFile tmpFile, True
  End With
End Function

Function GetFileExtensions()
  Dim sComm As String, txtStream As Object, tmpFile, tmpArr, Arr(), n As Long
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    tmpFile = .GetTempName
    sComm = "assoc" & " >" & tmpFile
    CreateObject("Wscript.Shell").Run "cmd /c " & sComm, 0, True
    Set txtStream = .OpenTextFile(tmpFile, 1)
    tmpArr = Split(txtStream.ReadAll, vbCrLf)
    txtStream.Close
    ReDim Arr(LBound(tmpArr) To UBound(tmpArr))
    For n = LBound(tmpArr) To UBound(tmpArr)
      Arr(n) = Trim(Split(tmpArr(n), "=")(0))
    Next
    GetFileExtensions = Arr
    .DeleteFile tmpFile, True
  End With
End Function

Sub Main()
  Dim ExtArr, Arr(), lR As Long, n As Long, tmp
  With Sheet1
    ExtArr = GetFileExtensions
    ReDim Arr(UBound(ExtArr, 1), 1 To 2)
    For lR = LBound(ExtArr, 1) To UBound(ExtArr, 1)
      tmp = GetAssociatedProgram(CStr(ExtArr(lR)))
      If Trim(tmp) <> "" Then
        Arr(n, 1) = CStr(ExtArr(lR))
        Arr(n, 2) = tmp
        n = n + 1
      End If
    Next
    .Range("A2").Resize(n, 2).Value = Arr
  End With
End Sub

Nhờ các bạn (nhất là những ai đang xài Windows XP) test giúp đoạn code trên bằng 2 cách:
- Mở file Excel mới, code toàn bộ code cho vào module và chạy Sub Main
- Chạy code trong file đính kèm dưới đây (bấm nút Run code)
Rất mong hồi âm từ các bạn! Các ơn trước
ANH TUẤN

 

[tungnguyen_kt]

- Chạy code trong file đính kèm dưới đây (bấm nút Run code)

ANH TUẤN

Hỏng rành code nhưng làm theo hướng dẫn của Anh thì nó chạy như sau: (Win XP - office 2007)

Extension​

|

Associated Program​

|
.032|C:\Program Files\ACD Systems\ACDSee\8.0\ACDSee8.exe|
.323|C:\WINDOWS\system32\msconf.dll|
.3g2|C:\Program Files\K-Lite Codec Pack\Media Player Classic\mplayerc.exe|
.3gp|C:\Program Files\K-Lite Codec Pack\Media Player Classic\mplayerc.exe|
.3gp2|C:\Program Files\K-Lite Codec Pack\Media Player Classic\mplayerc.exe|
.3gpp|C:\Program Files\K-Lite Codec Pack\Media Player Classic\mplayerc.exe|
.7z|C:\Program Files\WinRAR\WinRAR.exe|
.ace|C:\Program Files\WinRAR\WinRAR.exe|
.acw|C:\WINDOWS\system32\accwiz.exe|
.ade|C:\Program Files\Microsoft Office\Office12\MSACCESS.EXE|
.adn|C:\Program Files\Microsoft Office\Office12\MSACCESS.EXE|
.adp|C:\Program Files\Microsoft Office\Office12\MSACCESS.EXE|
.aif|C:\Program Files\Windows Media Player\wmplayer.exe|
.aifc|C:\Program Files\Windows Media Player\wmplayer.exe|
.aiff|C:\Program Files\Windows Media Player\wmplayer.exe|
.air|C:\PROGRA~1\COMMON~1\ADOBEA~1\Versions\1.0\ADOBEA~1.EXE|
.ani|C:\Program Files\ACD Systems\ACDSee\8.0\ACDSee8.exe|
.arj|C:\Program Files\WinRAR\WinRAR.exe|