Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

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

File & Folder Creation Fail on SOME XP Machines

I have a program that allows Drag/Drop of eml files from Outlook Express to our program to copy them to our program's subdirectory (it is a unique anti-spam program).

If the subdirecotory does not exist,  the program uses the FileSystemObject to create it.  Then the files are copied to that directory by a simple File Open file for output & Print operation.

On some XP computers users report the subdirectory is created but no files appear in it and there is NO error message.   On other XP computers (one is at my office) the Subdirectory is NOT created and so the files are not either... and there is NO error!!

The install seems to run ok with no reported errors.  I am using InnoSetup and installing the scripting library using microsofts  program for this purpose and NOT trying to install scrrun.dll manually.

I find this really bizzare, since the program works great 3 of my home computers.  Here is a cut of the code section that does these tasks:

---------------------  cut of code ----------------------------------------------------------------------

        'create dir if not existing
        If Dir(App.Path & "\BadMail\") = "" Then
           fso.CreateFolder (App.Path & "\BadMail\")
         
        End If
       

        'get a unique file name, the function is stored in modFileSave.
        strEmlFile = MakeUniqueFileName(App.Path & "\BadMail\", strEmlFile, "eml")
   
         msg = "An Email COPY will be saved to the following path and file name: " _
                & vbCrLf & App.Path & "\BadMail\" & strEmlFile
               
         MsgBox msg, vbOKOnly, "Please check to see if it was saved there!"
               
   
    fileHandle = FreeFile
   
    Open App.Path & "\badMail\" & strEmlFile For Output As #fileHandle
        Print #fileHandle, strData
    Close #fileHandle
   
    ------------------------------   end of code ----------------------------------------------------

I have postulated that some program is preventing the creation of EML files as they must be scanned be scanned by Norton before saving to the hard disk but that does not explain the lack of dirctory creation.  Also,  this files were not created even with Norton deactivated.  As far as I know the install was done from a Administrator enabled user.   I believe this failure was on XP Machines Home Ed.

Thanks,
Joe
0
drjoeross1
Asked:
drjoeross1
  • 7
  • 6
1 Solution
 
inthedarkCommented:
You should not use the scripting control as some users may have script blocking turned on. So any scripting control commands may or may not work.
0
 
inthedarkCommented:
Also you display the message before the file is saved, which may cause confusion.
0
 
inthedarkCommented:
Here are some replacements for the scripting object. Also you were using the Dir command which has been know to fail for serveral reasons.  So it needs to be retried a few times.  By placing code which can fail with a result you can test to see if each step worked.

Dim GF as New zGF ' place all of your handy functions into a class module, say called zGF
Dim OK
If Not GF.FolderExists("c:\MyFolder") Then
    OK = GF.MakeDir("c:\MyFolder")
    If Not OK Then
          MsgBox "Could not create folder: xxx" + GF.ErrorMessage
    End If
End If

etc.

And to save the file:

OK = GF.WriteFileOK(strEmlFile , strData)
If Not OK Then
      MsgBox "Could not create folder: xxx" + GF.ErrorMessage
End If





-------------------------------Extract from class zGF.cls
Public ErrorMessage As String
Public ErrorNumber As Long
Public Enum SlashOptions
    RemoveSlash = 0
    KeepSlash = 1
End Enum
Const MinutesPerDay As Double = 24# * 60#
Const SecondsPerDay As Double = MinutesPerDay * 60#
Const OneSecond As Double = 1# / SecondsPerDay
Const MillisecondsPerDay As Double = SecondsPerDay * 1000#

Const mdblOneSecond As Double = 1# / (60# * 1440#)
Const mdblOneMinute As Double = 1# / (1440#)

Public Function FileExists(psFileName As String) As Boolean

' Same as OK = Len(Dir("......"))>0 without any errors
' Fail safe test for a file name

Dim sFIle As String

sFIle = psFileName


FileExists = False
If Not IDE Then
    On Error GoTo ErrorTrap
End If

If False Then
ErrorTrap:
    ' wait for drive to speed up
    Dim lTry As Long
    lTry = lTry + 1
    If lTry > 10 Then
        Exit Function
    End If
    Delay 1 ' wait for one second for the drive to speed up
End If

If Len(Dir(sFIle)) = 0 Then
    FileExists = True
End If

End Function
Public Function FolderExists(psFolderName As String) As Boolean

Dim sFolder As String

sFolder = psFolderName
CheckSlash sFolder, RemoveSlash

FolderExists = False
If Not IDE Then
    On Error GoTo ErrorTrap
End If

If False Then
ErrorTrap:
    Dim lTry As Long
    lTry = lTry + 1
    If lTry > 10 Then
        Exit Function
    End If
    Delay 5
End If

If Len(Dir(sFolder, vbDirectory)) = 0 Then
    FolderExists = True
End If

End Function
Public Function MkDirOK(NewPath As String) As Boolean

' Create new path
Dim p$
p$ = NewPath
If Right(p$, 1) = "\" Then
    p$ = Left(p$, Len(p$) - 1)
End If
On Error Resume Next
MkDir p$
If Err.Number <> 0 Then
    ErrorMessage = Err.Description
    ErrorNumber = Err.Number
    MkDirOK = False
Else
    MkDirOK = True
End If
   
End Function
Public Sub CheckSlash(FolderName, Optional KeepSlash As SlashOptions = SlashOptions.KeepSlash)

' Removes/puts a slash at the end of a folder path
' GF.CheckSlash sFolderName ' make sure has a slash
' GF.CheckSlash sFolderName, SlashOptions.RemoveSlash ' remove slash if present

If KeepSlash = SlashOptions.KeepSlash Then

    If Right(FolderName, 1) <> "\" Then
        FolderName = FolderName + "\"
    End If
Else
    If Right(FolderName, 1) = "\" Then
        FolderName = Left(FolderName, Len(FolderName) - 1)
    End If
End If

End Sub
Public Sub Delay(DelaySeconds As Single)

' wait for time to pass
' GF.Delay 10 ' wait for 10 seconds

Dim WaitUntil As Date

WaitUntil = GetNow + (CDbl(DelaySeconds) * mdblOneSecond)

Do While GetNow < WaitUntil
    Sleep 100
    DoEvents
Loop

End Sub
Public Function IDE(Optional Genuine As Boolean) As Boolean

' Returns True if running in debug (IDE) mode
'         False if running in an EXE

'Example:
' If ADO.IDE Then Stop
If Not Genuine And LiveMode Then
    IDE = False
    Exit Function
End If

Static mIDEDone As Boolean
Static mIDE As Boolean

If Not mIDEDone Then ' See below
'To make this function work you need the following in your
' class declarations:
'Dim mIDEDone As Boolean
'Dim mIDE As Boolean

    ' just do this first time round then store the result
    On Error Resume Next
    Err.Clear
    Debug.Print 1 / 0;
    If Err.Number <> 0 Then
        mIDE = True
    Else
        mIDE = False
    End If
    mIDEDone = True
End If
IDE = mIDE
End Function
Public Function WriteFileOK(FileName As String, DataString) As Boolean

' saves DataString to a file FileName
' returns True if OK

Dim wlfn As Long

wlfn = FreeFile
On Error Resume Next
Err.Clear
WriteFileOK = False
Open FileName For Output As #wlfn
If Err.Number <> 0 Then
    ErrorMessage = Err.Description
    ErrorNumber = Err.Number
    Exit Function
End If
Print #wlfn, DataString;
Close wlfn
If Err.Number <> 0 Then
    Exit Function
End If
WriteFileOK = True

End Function
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
drjoeross1Author Commented:
Greetings,

Thanks for your response... some things I do not understand.  I gather that you are suggesting NOT using the Scripting Object because users can have that turned off somewhere. I will research this and It seems to make sense.... perhaps this is the problem I am seeing.

I gather that you want each process to REPORT on its success or failure and that is quite logical so I will add that.  

The removal / insertiion of the "slash"  makes sense though since all my directories are subdirectories,  I believe the slash does not fail, unless I miss something.

However the Cls funtion you kindly shared does not make sense to me.   I have added some comments as I watched it process  I appended  a comment and my name at each point and I am re-pasting it here so you can see my questions,  thank you,

There are 5 comments/questions indicated as:

    '<=== (1) Question xxxxxx xxxxxxxxxxxxxx  joe 11/04

-------------------- cls with Questions -------------------------------------------

Public ErrorMessage As String
Public ErrorNumber As Long
Public Enum SlashOptions
    RemoveSlash = 0
    KeepSlash = 1
End Enum
Const MinutesPerDay As Double = 24# * 60#
Const SecondsPerDay As Double = MinutesPerDay * 60#
Const OneSecond As Double = 1# / SecondsPerDay
Const MillisecondsPerDay As Double = SecondsPerDay * 1000#

Const mdblOneSecond As Double = 1# / (60# * 1440#)
Const mdblOneMinute As Double = 1# / (1440#)

Public Function FileExists(psFileName As String) As Boolean

' Same as OK = Len(Dir("......"))>0 without any errors
' Fail safe test for a file name

Dim sFIle As String

sFIle = psFileName


FileExists = False
If Not IDE Then
    On Error GoTo ErrorTrap
End If

If False Then
ErrorTrap:
    ' wait for drive to speed up
    Dim lTry As Long
    lTry = lTry + 1
    If lTry > 10 Then
        Exit Function
    End If
    Delay 1 ' wait for one second for the drive to speed up
End If

If Len(Dir(sFIle)) = 0 Then
    FileExists = True
End If

End Function
Public Function FolderExists(psFolderName As String) As Boolean

Dim sFolder As String

sFolder = psFolderName
CheckSlash sFolder, RemoveSlash

FolderExists = False
If Not IDE Then
    On Error GoTo ErrorTrap
End If

If False Then    '<=== (1) there is no variable to be labled as FALSE What are we testing??  11/04 Joe
ErrorTrap:
    Dim lTry As Long
    lTry = lTry + 1
    If lTry > 10 Then
        Exit Function
    End If
    Delay 5
End If

If Len(Dir(sFolder, vbDirectory)) = 0 Then   '<=== (2)This function seems like it should report True if  Len > 0  ???  11/04 Joe
    FolderExists = True
End If

End Function
Public Function MkDirOK(NewPath As String) As Boolean

' Create new path
Dim p$
p$ = NewPath
If Right(p$, 1) = "\" Then
    p$ = Left(p$, Len(p$) - 1)
End If
On Error Resume Next
MkDir p$
If Err.Number <> 0 Then
    ErrorMessage = Err.Description
    ErrorNumber = Err.Number
    MkDirOK = False
Else
    MkDirOK = True
End If
   
End Function
Public Sub CheckSlash(FolderName, Optional KeepSlash As SlashOptions = SlashOptions.KeepSlash)

' Removes/puts a slash at the end of a folder path
' GF.CheckSlash sFolderName ' make sure has a slash
' GF.CheckSlash sFolderName, SlashOptions.RemoveSlash ' remove slash if present

If KeepSlash = SlashOptions.KeepSlash Then

    If Right(FolderName, 1) <> "\" Then
        FolderName = FolderName + "\"
    End If
Else
    If Right(FolderName, 1) = "\" Then
        FolderName = Left(FolderName, Len(FolderName) - 1)
    End If
End If

End Sub
Public Sub Delay(DelaySeconds As Single)

' wait for time to pass
' GF.Delay 10 ' wait for 10 seconds

Dim WaitUntil As Date

WaitUntil = GetNow + (CDbl(DelaySeconds) * mdblOneSecond)

Do While GetNow < WaitUntil
    Sleep 100
    DoEvents
Loop

End Sub
Public Function IDE(Optional Genuine As Boolean) As Boolean

' Returns True if running in debug (IDE) mode
'         False if running in an EXE

'Example:
' If ADO.IDE Then Stop
If Not Genuine And LiveMode Then '<===(3) "LiveMode"  has NO reference anywhere?? JOE 11/04
    IDE = False                              '<=== (4)What would "genuine" indicate???? Joe 11/04
    Exit Function
End If

Static mIDEDone As Boolean
Static mIDE As Boolean

If Not mIDEDone Then ' See below
'To make this function work you need the following in your
' class declarations:
'Dim mIDEDone As Boolean
'Dim mIDE As Boolean

    ' just do this first time round then store the result
    On Error Resume Next
    Err.Clear
    Debug.Print 1 / 0;   '<===(5)causes error in IDE mode and stops operation. What's the value? Joe 11/04
    If Err.Number <> 0 Then
        mIDE = True
    Else
        mIDE = False
    End If
    mIDEDone = True
End If
IDE = mIDE
End Function
Public Function WriteFileOK(FileName As String, DataString) As Boolean

' saves DataString to a file FileName
' returns True if OK

Dim wlfn As Long

wlfn = FreeFile
On Error Resume Next
Err.Clear
WriteFileOK = False
Open FileName For Output As #wlfn
If Err.Number <> 0 Then
    ErrorMessage = Err.Description
    ErrorNumber = Err.Number
    Exit Function
End If
Print #wlfn, DataString;
Close wlfn
If Err.Number <> 0 Then
    Exit Function
End If
WriteFileOK = True

End Function

-------------------------  end paste -------------------------------

Thanks for your clarifcation
Joe



0
 
inthedarkCommented:
(1) The idea here is that you can paste this code into the start of any sub or function, I have different variations of how the error handling is done, I just paste the pre-created code at the top of the function.

What the "If False" does is say don't execute
If False Then    '<=== (1)
    '  Anything here will be ignored (but in our case the error will force the function tor estart after a short delay.
End If

(2) You are right, its a bug.
It did say this:

If Dir(sFolder, vbDirectory)) <> "" Then  
    FolderExists = True
End If

But it is faster to test with Len so I edited and did not test, so as you sugget it should say:

If Len(Dir(sFolder, vbDirectory)) <> 0 Then
    FolderExists = True
End If

(3)

At the start of the class you need:
Const LiveMode As Boolean = False ' Edit this to True inorder to test your error handling.

In the following example when I am testing my function I want all erros to fail so that I may correct and faults in the code
Public Function Example() As Something

If Not IDE Then
    On Error GoTo ErrorTrap ' this will only become active in a Compiled exe
End If

' now do some code which can fail

' and may end like this
Exit Function

ErrorTrap:
MsgBox "We have a problem"
End Function

By changing LiveMode = True, when you run in the IDE te ErrorTrap will be set.

(4)

Sometimes you always need to know if you are in IDE or EXE. For example, in an IIS application the following code will work on NT in an IDE but it will hang your app on Win 2000+ (and machine needs a reboot).

Application.Lock ' wait until you have exclusive rights to change an application variable
Application("Counter") = Application("Counter") ' <====IDE hangs here, but EXE works fine.
Application.UnLock

So irrespective of the LiveMode setting you need to know if in IDE so you can recode like this to avoice system hang:

bSkipLock = GF.IDE(True) ' Is it realy in IDE?

If Not bSkipLock Then
   Application.Lock ' wait until you have exclusive rights to change an application variable
End If
Application("Counter") = Application("Counter") ' <====IDE hangs here, but EXE works fine.
If Not bSkipLock Then
    Application.UnLock
End If

(5)

Debug.Print 1/0 ' is just a simple way of finding if your are in IDE.

In an EXE the Debug statments are ignored so Err.Number will always be zero.

Hope this helps:~)





0
 
inthedarkCommented:
PS divide anything by zero and you get an overflow error becuase the result is infinity
0
 
drjoeross1Author Commented:
So far I am not sure this is working.   I have a question about the delay area.  It seems that  the "GetNow "  is not being used?   Is there a missing sub for function for the "GetNow" ??
Thanks,
Joe

Public Sub Delay(DelaySeconds As Single)

' wait for time to pass
' GF.Delay 10 ' wait for 10 seconds

Dim WaitUntil As Date

WaitUntil = GetNow + (CDbl(DelaySeconds) * mdblOneSecond)

Do While GetNow < WaitUntil
    Sleep 100
    DoEvents
Loop

End Sub
0
 
drjoeross1Author Commented:
I also noticed (later ... sorry) that the  "SLEEP"  statement relates to nothing... and causes an error.  What is this supposed to be?

Thanks again,
Joe
0
 
inthedarkCommented:
I was surprised at how slow Microsoft's Now function was. Not only slow, but inacurate. So I created my own version which is acruate to 0.016 MS and also is a lot faster.


Private Declare Function GetTickCount Lib "kernel32" () As Long

Function GetNow() As Date

' return Now to the highest possible resolution

'Private Sub Form_Load()
'
'
'Dim R As Long
''For R = 1 To 1000
''    Debug.Print CStr(GetNow)
''Next R
''Stop
'Dim lastdt As Date
'Dim dt As Date
'Dim loopdt As Date
'dt = GetNow ' initailise getnow just for no reason
'
'R = 0
'dt = GetNow + (OneSecond * 5#)
'Do Until GetNow > dt
'    lastdt = Now ' loop using Now
'    R = R + 1
'Loop
'
'Dim store As Long
'store = R
'R = 0
'dt = GetNow + (OneSecond * 5#)
'Do Until GetNow > dt
'    lastdt = GetNow ' Loop using GetNow
'    R = R + 1
'Loop
'
'Dim sMessage As String
'sMessage = sMessage + "MS Now() loops: " + CStr(store) + vbCrLf
'sMessage = sMessage + "InTheDark' GetNow() loops: " + CStr(R) + vbCrLf
'sMessage = sMessage + "InTheDark was faster by  " + Format(100 * (R - store) / store, "0.00") + "%" + vbCrLf
'MsgBox sMessage
''Do
''
''    R = R + 1
''    If dt > lastdt Then
''        Debug.Print GetDateWithMS(dt)
''        lastdt = dt
''        R = R + 1
''        If R > 50 Then Exit Do
''    End If
''Loop
''MsgBox "check debug"
'End Sub


Static bDone As Boolean
Static bLowRes As Boolean
Static dblStartPeriod As Double
Static curStartHResTimer As Currency
Static curTimer As Currency
Static curFrequency As Currency
Static lngStartTicks As Long
Static lngNowTicks As Long
If Not bDone Then
    dblStartPeriod = CDbl(date) + (CDbl(Timer) / SecondsPerDay)
'    bDone = QueryPerformanceCounter(curStartHResTimer)
'    If Not bDone Then
'        bLowRes = True ' need to use lower resuolution timer
        lngStartTicks = GetTickCount
'        If lngStartTicks = 0 Then
'            lngStartTicks = 1 ' this should never happen, but it may
'        End If
'    Else
'        QueryPerformanceFrequency curFrequency
'    End If
    bLowRes = True
    bDone = True
End If
If bLowRes Then
    lngNowTicks = GetTickCount
    ' handle server up for 49 days
    If lngNowTicks < lngStartTicks Then
        dblStartPeriod = date + (CDbl(Timer) / SecondsPerDay)
        lngStartTicks = GetTickCount
        If lngStartTicks = 0 Then
            lngStartTicks = 1 ' this should never happen, but it may
        End If
        lngNowTicks = GetTickCount
    End If
   
    GetNow = dblStartPeriod + ((CDbl(lngNowTicks - lngStartTicks) * 0.001) / SecondsPerDay)
Else

    ' there are some bugs in the high resolution timer so don't use it!
   
'    QueryPerformanceCounter curTimer
'    ' handle 49 day roll over
'    If curTimer < curStartHResTimer Then
'        dblStartPeriod = date + CDbl(Timer) / SecondsPerDay
'        QueryPerformanceCounter curStartHResTimer
'        QueryPerformanceCounter curTimer
'    End If
'    GetNow = dblStartPeriod + CDbl((curTimer - curStartHResTimer) / curFrequency) / SecondsPerDay
End If

End Function
0
 
inthedarkCommented:
And sleep is processor friendly:

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
0
 
drjoeross1Author Commented:
Sorry for the delay in repsonding but  the one user who has the problem is away on vaction.... He will be back this next week and I will test your solution on his computer

Joe
0
 
drjoeross1Author Commented:
I have asked the beta tester to run the new program following InTheDark's recommendations.   Since we are close to the Holidays it is taking time to get an answer. .... not to mention that he went to Tahiti for 3 weeks prior.

Anyway,  I should get feedback in a few days.   If its your policy to close at this point.... that is you decision.  InTheDark certainly made some good recommendations..... but I have not been able to confirm that using the FSO Scripting is in fact being blocked by programs like Norton A/V.... the premise of this dialog (I believe).

Thank you,

Joe
0
 
drjoeross1Author Commented:
Greetings:

The suggestion by "InTheDark"  appears to have solved the problem!   It appears that the VB Scripting Object is blocked by some A/V or other programs.

Thank you,

Joe
0

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

  • 7
  • 6
Tackle projects and never again get stuck behind a technical roadblock.
Join Now