Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1260
  • Last Modified:

FileSystemObject folderexists with mapped drives VB6

I have the following code:-

Public Function CheckFolderExists(OrigFile As String)
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    FolderExists = fs.FolderExists(OrigFile)
End Function
which returns the correct result for a local drive but not for a mapped drive.

Any ideas?
0
grwallace
Asked:
grwallace
  • 13
  • 11
1 Solution
 
cmorbachCommented:
Have you ever tried PathFileExists-function?

http://vbnet.mvps.org/index.html?code/fileapi/pathfileexists.htm
0
 
grwallaceAuthor Commented:
I tried it but it gives the same problme
0
 
cmorbachCommented:
You could convert the mapped drive-letter to UNC:
http://support.microsoft.com/kb/192689

and then make the checks with PathFileExists again.
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
grwallaceAuthor Commented:
I tried this, and the test program returned a message stating that the drive letter was not found
0
 
cmorbachCommented:
What exactly does the test app do? Could you post full&runnable code? What is the mapped drive's letter and where does it ppoint to? Please provide these information.
0
 
grwallaceAuthor Commented:
The mapped drive letter is t:

The problem appears to be Vista specific, as it works fine on XP machines.
If you are not using Vista then you will be unable to replicate the problem. That is what I have worked out over the past hour!

0
 
cmorbachCommented:
I have Vista here. If you paste the code of your sample app, I could help to answer you question quickly or fix it accordingly.
0
 
grwallaceAuthor Commented:
I tried running the application created by the code from the link which you gave me before:-
http://support.microsoft.com/kb/192689
and it returns not found on Vista.

If you create a new VB progect and add 2 commandbuttons and paste in the following code, but with local & network folders which exist on your machine that is what I a doing


Option Explicit

Dim OrigFile As String, FolderExists As Boolean
Private Sub Command1_Click()
    OrigFile = "c:\comtass\progs"
    CheckFolderExists OrigFile
   
   
End Sub
Private Sub Command2_Click()
    OrigFile = "t:\comtass\progs"
    CheckFolderExists OrigFile
End Sub
Public Function CheckFolderExists(OrigFile As String)
' Add the Microsoft Scripting Runtime reference if this causes a problem
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    FolderExists = fs.FolderExists(OrigFile)
     If FolderExists = True Then
        MsgBox OrigFile & " Exists"
    Else
        MsgBox OrigFile & " Does Not Exist"
    End If
End Function
0
 
cmorbachCommented:
Well, for me PathFileExists as mentioned in my first comment does work under vista! Here my Code:
Public Class Form1
 
    Dim OrigFile As String, FolderExists As Boolean
 
    Private Declare Function PathFileExists Lib "shlwapi" _
   Alias "PathFileExistsA" _
  (ByVal pszPath As String) As Long
 
    Public Function CheckFolderExists(ByVal OrigFile As String)
        ' Add the Microsoft Scripting Runtime reference if this causes a problem
        Dim fs
        fs = CreateObject("Scripting.FileSystemObject")
        'FolderExists = fs.FolderExists(OrigFile)
        FolderExists = PathFileExists(OrigFile)
 
        If FolderExists = True Then
            MsgBox(OrigFile & " Exists")
        Else
            MsgBox(OrigFile & " Does Not Exist")
        End If
    End Function
 
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        OrigFile = "c:\test"
        CheckFolderExists(OrigFile)
    End Sub
 
    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        OrigFile = "z:\test\mgm\"
        CheckFolderExists(OrigFile)
    End Sub
End Class

Open in new window

0
 
cmorbachCommented:
WAIT...it always returns exists...  :/
let me see again!
0
 
cmorbachCommented:
THIS works (for me):

 
Public Class Form1
 
    Dim OrigFile As String, FolderExists As Long, test As Integer
 
    Private Declare Function PathFileExists Lib "shlwapi" _
   Alias "PathFileExistsA" _
  (ByVal pszPath As String) As Long
 
    Public Function CheckFolderExists(ByVal OrigFile As String)
        ' Add the Microsoft Scripting Runtime reference if this causes a problem
        Dim fs
        fs = CreateObject("Scripting.FileSystemObject")
        'FolderExists = fs.FolderExists(OrigFile)
 
        FolderExists = PathFileExists(OrigFile)
        test = (FolderExists Mod 2)
 
        If test = 1 Then
            MsgBox(OrigFile & " Exists")
        Else
            MsgBox(OrigFile & " Does Not Exist")
        End If
    End Function
 
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        OrigFile = "c:\test\mgm"
        CheckFolderExists(OrigFile)
    End Sub
 
    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        OrigFile = "z:\test\mgm"
        CheckFolderExists(OrigFile)
    End Sub
End Class

Open in new window

0
 
grwallaceAuthor Commented:
yes, but my program is a VB6 program and not a VB.Net program.

I tried this in VB6 by changing the click events and adding the scripting runtime reference but it doe not run
I do appreciate your effort though
0
 
cmorbachCommented:
> but it doe not run
Tell me which error occurs, please.
0
 
grwallaceAuthor Commented:
I get a runtime error 438 - item dosen't support this property or method in the

fs = CreateObject("Scripting.FileSystemObject")

line
0
 
cmorbachCommented:
SOLUTION: regist the scrrun.dll start -> run -> regsvr32 c:\windows\system32\scrrun.dll scrrun.dll may be under different folder.
0
 
grwallaceAuthor Commented:
When I tried to do this I got the message:-

the module "C:\WINDOWS|SYSTEM32\SCRRUN.DLL" was loaded but the call to DllRegisterServer failed with error code 0z80004005

0
 
cmorbachCommented:
Did you run it as Administrator?

0x80004005 denotes "Access is denied" error. See if running the Regsvr32 command-line from an elevated Command Prompt helps
0
 
grwallaceAuthor Commented:
Running as an administer did succeed, but the problme with the program persists
0
 
cmorbachCommented:
Wait a minute:

>I get a runtime error 438 - item dosen't support this property or method in the
>fs = CreateObject("Scripting.FileSystemObject")
>line
This is'n used anymore in the code I gave you! I used the PathFileExists function declared in shlwapi.dll. The error must be somewhere else! Forget about the regsvr32 procedure and try again this code:

Public Class Form1
 
    Dim OrigFile As String, FolderExists As Long, test As Integer
 
    Private Declare Function PathFileExists Lib "shlwapi" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
 
    Public Sub CheckFolderExists(ByVal OrigFile As String)
        ' Add the Microsoft Scripting Runtime reference if this causes a problem
        'Dim fs
        'fs = CreateObject("Scripting.FileSystemObject")
        'FolderExists = fs.FolderExists(OrigFile)
 
        FolderExists = PathFileExists(OrigFile)
        test = (FolderExists Mod 2)
 
        If test = 1 Then
            MsgBox(OrigFile & " Exists")
        Else
            MsgBox(OrigFile & " Does Not Exist")
        End If
    End Sub
 
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        OrigFile = "c:\test\mgm"
        CheckFolderExists(OrigFile)
    End Sub
 
    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        OrigFile = "G:\Software\Treiber\Intel S3210"
        CheckFolderExists(OrigFile)
    End Sub
End Class

Open in new window

0
 
grwallaceAuthor Commented:
THe original problem persists I'm afraid

If you look  at the atttached screenshot you will command prompt window in the folder which the program says doesn't exist

Clip2.jpg
0
 
cmorbachCommented:
That's sad...did you try the method using unc as proposed in my second comment?

Copy this in a new vb6 form and add a button1
      Option Explicit
 
      Private Const RESOURCETYPE_ANY = &H0
      Private Const RESOURCE_CONNECTED = &H1
 
      Private Type NETRESOURCE
         dwScope As Long
         dwType As Long
         dwDisplayType As Long
         dwUsage As Long
         lpLocalName As Long
         lpRemoteName As Long
         lpComment As Long
         lpProvider As Long
      End Type
 
      Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias _
         "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, _
         ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) _
         As Long
 
      Private Declare Function WNetEnumResource Lib "mpr.dll" Alias _
         "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, _
         lpBuffer As Any, lpBufferSize As Long) As Long
 
      Private Declare Function WNetCloseEnum Lib "mpr.dll" ( _
         ByVal hEnum As Long) As Long
 
      Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" _
         (ByVal lpString As Any) As Long
 
      Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
         (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
         
            Private Declare Function PathFileExists Lib "shlwapi" _
   Alias "PathFileExistsA" _
  (ByVal pszPath As String) As Long
 
 
 
 
      Private Sub Command1_Click()
        Dim path, letter, rest, unc, newpath As String
        
      
        
        path = "t:\comtass\progs"        '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
        letter = Mid(path, 1, 2)
        rest = Mid(path, 3)
      
        unc = LetterToUNC(letter)
        newpath = unc & rest
        
        CheckFolderExists (newpath)
 
      End Sub
      
      
      
Public Function CheckFolderExists(OrigFile As String)
' Add the Microsoft Scripting Runtime reference if this causes a problem
    Dim fs
    Dim FolderExists As Boolean
    
    'method 1
    Set fs = CreateObject("Scripting.FileSystemObject")
    FolderExists = fs.FolderExists(OrigFile)
     If FolderExists = True Then
        MsgBox OrigFile & " Exists"
    Else
        MsgBox OrigFile & " Does Not Exist"
    End If
    
    'method 2
    FolderExists = PathFileExists(OrigFile)
 
    If FolderExists = True Then
        MsgBox (OrigFile & " Exists")
    Else
        MsgBox (OrigFile & " Does Not Exist")
    End If
   
    
End Function
 
 
      Function LetterToUNC(ByVal DriveLetter As String) As String
         Dim hEnum As Long
         Dim NetInfo(1023) As NETRESOURCE
         Dim entries As Long
         Dim nStatus As Long
         Dim LocalName As String
         Dim UNCName As String
         Dim i As Long
         Dim r As Long
 
         ' Begin the enumeration
         nStatus = WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, _
            0&, ByVal 0&, hEnum)
 
         LetterToUNC = "Drive Letter Not Found"
 
         'Check for success from open enum
         If ((nStatus = 0) And (hEnum <> 0)) Then
            ' Set number of entries
            entries = 1024
 
            ' Enumerate the resource
            nStatus = WNetEnumResource(hEnum, entries, NetInfo(0), _
               CLng(Len(NetInfo(0))) * 1024)
 
            ' Check for success
            If nStatus = 0 Then
               For i = 0 To entries - 1
                  ' Get the local name
                  LocalName = ""
                  If NetInfo(i).lpLocalName <> 0 Then
                     LocalName = Space(lstrlen(NetInfo(i).lpLocalName) + 1)
                     r = lstrcpy(LocalName, NetInfo(i).lpLocalName)
                  End If
 
                  ' Strip null character from end
                  If Len(LocalName) <> 0 Then
                     LocalName = Left(LocalName, (Len(LocalName) - 1))
                  End If
 
                  If UCase$(LocalName) = UCase$(DriveLetter) Then
                     ' Get the remote name
                     UNCName = ""
                     If NetInfo(i).lpRemoteName <> 0 Then
                        UNCName = Space(lstrlen(NetInfo(i).lpRemoteName) _
                           + 1)
                        r = lstrcpy(UNCName, NetInfo(i).lpRemoteName)
                     End If
 
                     ' Strip null character from end
                     If Len(UNCName) <> 0 Then
                        UNCName = Left(UNCName, (Len(UNCName) _
                           - 1))
                     End If
 
                     ' Return the UNC path to drive
                     LetterToUNC = UNCName
 
                     ' Exit the loop
                     Exit For
                  End If
               Next i
            End If
         End If
 
         ' End enumeration
         nStatus = WNetCloseEnum(hEnum)
      End Function

Open in new window

0
 
grwallaceAuthor Commented:
Unfortunately this returns:-

drive letter not found\comtass\progs Does Not Exist

0
 
cmorbachCommented:
my last option - catch the output of the command prompt to check if the folder exists.
include the code below into a new module and create a new form with:

Private Sub Command1_Click()
    MsgBox GetCommandOutput("cmd /c dir c:\windows\temp\")
    MsgBox GetCommandOutput("cmd /c dir c:\doesnotexist\")
End Sub

Use string compare functions on the result displayed in the message boxes here.


What OS are you using Vista x64?
Have you admin rights?
Did you try to disable UAC?

Option Explicit
''''''''''''''''''''''''''''''''''''''''
' Joacim Andersson, Brixoft Software
' http://www.brixoft.net
''''''''''''''''''''''''''''''''''''''''
 
' STARTUPINFO flags
Private Const STARTF_USESHOWWINDOW = &H1
Private Const STARTF_USESTDHANDLES = &H100
 
' ShowWindow flags
Private Const SW_HIDE = 0
 
' DuplicateHandle flags
Private Const DUPLICATE_CLOSE_SOURCE = &H1
Private Const DUPLICATE_SAME_ACCESS = &H2
 
' Error codes
Private Const ERROR_BROKEN_PIPE = 109
 
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
 
Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
 
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
 
Private Declare Function CreatePipe _
 Lib "kernel32" ( _
 phReadPipe As Long, _
 phWritePipe As Long, _
 lpPipeAttributes As Any, _
 ByVal nSize As Long) As Long
 
Private Declare Function ReadFile _
 Lib "kernel32" ( _
 ByVal hFile As Long, _
 lpBuffer As Any, _
 ByVal nNumberOfBytesToRead As Long, _
 lpNumberOfBytesRead As Long, _
 lpOverlapped As Any) As Long
 
Private Declare Function CreateProcess _
 Lib "kernel32" Alias "CreateProcessA" ( _
 ByVal lpApplicationName As String, _
 ByVal lpCommandLine As String, _
 lpProcessAttributes As Any, _
 lpThreadAttributes As Any, _
 ByVal bInheritHandles As Long, _
 ByVal dwCreationFlags As Long, _
 lpEnvironment As Any, _
 ByVal lpCurrentDriectory As String, _
 lpStartupInfo As STARTUPINFO, _
 lpProcessInformation As PROCESS_INFORMATION) As Long
 
Private Declare Function GetCurrentProcess _
 Lib "kernel32" () As Long
 
Private Declare Function DuplicateHandle _
 Lib "kernel32" ( _
 ByVal hSourceProcessHandle As Long, _
 ByVal hSourceHandle As Long, _
 ByVal hTargetProcessHandle As Long, _
 lpTargetHandle As Long, _
 ByVal dwDesiredAccess As Long, _
 ByVal bInheritHandle As Long, _
 ByVal dwOptions As Long) As Long
 
Private Declare Function CloseHandle _
 Lib "kernel32" ( _
 ByVal hObject As Long) As Long
 
Private Declare Function OemToCharBuff _
 Lib "user32" Alias "OemToCharBuffA" ( _
 lpszSrc As Any, _
 ByVal lpszDst As String, _
 ByVal cchDstLength As Long) As Long
 
' Function GetCommandOutput
'
' sCommandLine:  [in] Command line to launch
' blnStdOut        [in,opt] True (defualt) to capture output to STDOUT
' blnStdErr        [in,opt] True to capture output to STDERR. False is default.
' blnOEMConvert:   [in,opt] True (default) to convert DOS characters to Windows, False to skip conversion
'
' Returns:       String with STDOUT and/or STDERR output
'
Public Function GetCommandOutput( _
 sCommandLine As String, _
 Optional blnStdOut As Boolean = True, _
 Optional blnStdErr As Boolean = False, _
 Optional blnOEMConvert As Boolean = True _
) As String
 
    Dim hPipeRead As Long, hPipeWrite1 As Long, hPipeWrite2 As Long
    Dim hCurProcess As Long
    Dim sa As SECURITY_ATTRIBUTES
    Dim si As STARTUPINFO
    Dim pi As PROCESS_INFORMATION
    Dim baOutput() As Byte
    Dim sNewOutput As String
    Dim lBytesRead As Long
    Dim fTwoHandles As Boolean
 
    Dim lRet As Long
 
    Const BUFSIZE = 1024      ' pipe buffer size
 
    ' At least one of them should be True, otherwise there's no point in calling the function
    If (Not blnStdOut) And (Not blnStdErr) Then
        Err.Raise 5         ' Invalid Procedure call or Argument
    End If
 
    ' If both are true, we need two write handles. If not, one is enough.
    fTwoHandles = blnStdOut And blnStdErr
 
    ReDim baOutput(BUFSIZE - 1) As Byte
 
    With sa
        .nLength = Len(sa)
        .bInheritHandle = 1    ' get inheritable pipe handles
    End With
 
    If CreatePipe(hPipeRead, hPipeWrite1, sa, BUFSIZE) = 0 Then
        Exit Function
    End If
 
    hCurProcess = GetCurrentProcess()
 
    ' Replace our inheritable read handle with an non-inheritable. Not that it
    ' seems to be necessary in this case, but the docs say we should.
    Call DuplicateHandle(hCurProcess, hPipeRead, hCurProcess, hPipeRead, 0&, _
                         0&, DUPLICATE_SAME_ACCESS Or DUPLICATE_CLOSE_SOURCE)
 
    ' If both STDOUT and STDERR should be redirected, get an extra handle.
    If fTwoHandles Then
        Call DuplicateHandle(hCurProcess, hPipeWrite1, hCurProcess, hPipeWrite2, 0&, _
                             1&, DUPLICATE_SAME_ACCESS)
    End If
 
    With si
        .cb = Len(si)
        .dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
        .wShowWindow = SW_HIDE          ' hide the window
 
        If fTwoHandles Then
            .hStdOutput = hPipeWrite1
            .hStdError = hPipeWrite2
        ElseIf blnStdOut Then
            .hStdOutput = hPipeWrite1
        Else
            .hStdError = hPipeWrite1
        End If
    End With
 
    If CreateProcess(vbNullString, sCommandLine, ByVal 0&, ByVal 0&, 1, 0&, _
     ByVal 0&, vbNullString, si, pi) Then
 
        ' Close thread handle - we don't need it
        Call CloseHandle(pi.hThread)
 
        ' Also close our handle(s) to the write end of the pipe. This is important, since
        ' ReadFile will *not* return until all write handles are closed or the buffer is full.
        Call CloseHandle(hPipeWrite1)
        hPipeWrite1 = 0
        If hPipeWrite2 Then
            Call CloseHandle(hPipeWrite2)
            hPipeWrite2 = 0
        End If
 
        Do
            ' Add a DoEvents to allow more data to be written to the buffer for each call.
            ' This results in fewer, larger chunks to be read.
            'DoEvents
 
            If ReadFile(hPipeRead, baOutput(0), BUFSIZE, lBytesRead, ByVal 0&) = 0 Then
                Exit Do
            End If
 
            If blnOEMConvert Then
                ' convert from "DOS" to "Windows" characters
                sNewOutput = String$(lBytesRead, 0)
                Call OemToCharBuff(baOutput(0), sNewOutput, lBytesRead)
            Else
                ' perform no conversion (except to Unicode)
                sNewOutput = Left$(StrConv(baOutput(), vbUnicode), lBytesRead)
            End If
 
            GetCommandOutput = GetCommandOutput & sNewOutput
 
            ' If you are executing an application that outputs data during a long time,
            ' and don't want to lock up your application, it might be a better idea to
            ' wrap this code in a class module in an ActiveX EXE and execute it asynchronously.
            ' Then you can raise an event here each time more data is available.
            'RaiseEvent OutputAvailabele(sNewOutput)
        Loop
 
        ' When the process terminates successfully, Err.LastDllError will be
        ' ERROR_BROKEN_PIPE (109). Other values indicates an error.
 
        Call CloseHandle(pi.hProcess)
    Else
        GetCommandOutput = "Failed to create process, check the path of the command line."
    End If
 
    ' clean up
    Call CloseHandle(hPipeRead)
    If hPipeWrite1 Then
        Call CloseHandle(hPipeWrite1)
    End If
    If hPipeWrite2 Then
        Call CloseHandle(hPipeWrite2)
    End If
End Function

Open in new window

0
 
grwallaceAuthor Commented:
Hi,
I am using Vista Home Premium, and I am logging in to the server as Administrator.

I now have to leave to go on vacation for a couple of weeks, but I am sure that I will be able to do something with your last example.

Thanks a lot  and  10 out of 10 for you efforts
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 13
  • 11
Tackle projects and never again get stuck behind a technical roadblock.
Join Now