Groups > comp.lang.basic.visual.misc > #1867

Re: Renaming a Directory in VB6????

From	Jason Keats <jkeats@melbpcDeleteThis.org.au>
Newsgroups	comp.lang.basic.visual.misc
Subject	Re: Renaming a Directory in VB6????
References	(2 earlier) <4e20d437-1a2c-4812-a803-55d3121f5600@o7g2000prn.googlegroups.com> <iie3st$rf6$1@news.eternal-september.org> <a9ca46ef-d18c-4e08-ba62-1696a65f906c@m27g2000prj.googlegroups.com> <1d45dee2-b566-46d2-a073-898d2aa4f426@o14g2000prb.googlegroups.com> <6d23b61f-1d5a-4ced-81dc-426f6852f2bf@u24g2000prn.googlegroups.com>
Message-ID	<TmS2p.9524$MF5.8605@viwinnwfe02.internal.bigpond.com> (permalink)
Date	2011-02-04 23:33 +1100
Organization	BigPond

Show all headers | View raw

jason@smkzone.com wrote:
> I DO have another "minor" problem though.  The following code is
> SUPPOSED to create a separate text file for each entry in my
> database.  Instead, it creates ONE file with the info for ALL the
> entries! How do I fix this?:
>
> Public Sub AddFiles()
> Dim cnn As ADODB.Connection
> Dim cmm As ADODB.Command
> Dim rss As ADODB.Recordset
> Dim fPath As String, folder As String, folder2 As String, fName As
> String, fileName As String
> Set cnn = New ADODB.Connection
> With cnn
>     .Provider = "Microsoft.Jet.OLEDB.4.0"
>     .CursorLocation = adUseClient
>     .Mode = adModeReadWrite
>     .Open DBPath
> End With
> Set cmm = New ADODB.Command
> With cmm
>     .ActiveConnection = cnn
>     .CommandText = "SELECT * FROM Employees;"
>     .CommandType = adCmdText
> End With
> Set rss = New ADODB.Recordset
> With rss
>     .CursorType = adOpenStatic
>     .CursorLocation = adUseClient
>     .LockType = adLockOptimistic
>     .Open cmm
> End With
> fPath = App.Path
> folder = "\Pay Period\"
> folder2 = "Current\"
> fileName = rss.Fields(0).Value&  ".txt"
> fName = Dir(fPath&  folder&  folder2, vbDirectory)
> If fName = "" Then
>     Exit Sub
> Else
>     Dim fName2 As String
>     Dim FullPath As String
>     FullPath = fPath&  folder&  folder2&  fileName
>     fName2 = Dir(fPath&  folder&  folder2&  fileName)
>     Do Until rss.EOF
>        If fName2 = "" Then
>           Dim x As Integer
>           x = FreeFile
>           Open FullPath For Append As #x
>           Dim sName As String
>           Dim sSSN As String
>           Dim sENum As String
>           sName = rss.Fields(0).Value
>           sSSN = "Social Security Number: "&  rss.Fields(1).Value
>           sENum = "Employee Number: "&  rss.Fields(2).Value
>           Write #x, sName&  vbCrLf&  sSSN&  vbCrLf&  sENum&  vbCrLf
>           Close #x
>           rss.MoveNext
>        End If
>     Loop
> End If
> rss.Close
> Set rss = Nothing
> Set cmm = Nothing
> cnn.Close
> Set cnn = Nothing
> Exit Sub
> End Sub
>

The minimum changes you need to make are...

Public Sub AddFiles()
     Dim cnn As ADODB.Connection
     Dim cmm As ADODB.Command
     Dim rss As ADODB.Recordset
     Dim fPath As String, folder As String, folder2 As String, fName As 
String, fileName As String
     Set cnn = New ADODB.Connection
     With cnn
         .Provider = "Microsoft.Jet.OLEDB.4.0"
         .CursorLocation = adUseClient
         .Mode = adModeReadWrite
         .Open DBPath
     End With

     Set cmm = New ADODB.Command
     With cmm
         .ActiveConnection = cnn
         .CommandText = "SELECT * FROM Employees;"
         .CommandType = adCmdText
     End With
     Set rss = New ADODB.Recordset
     With rss
         .CursorType = adOpenStatic
         .CursorLocation = adUseClient
         .LockType = adLockOptimistic
         .Open cmm
     End With
     fPath = App.Path
     folder = "\Pay Period\"
     folder2 = "Current\"
     'fileName = rss.Fields(0).Value & ".txt"
     fName = Dir(fPath & folder & folder2, vbDirectory)
     If fName = "" Then
         'Exit Sub       'prevents closing recordset & connection
     Else
         Dim fName2 As String
         Dim FullPath As String
         'FullPath = fPath & folder & folder2 & fileName
         'fName2 = Dir(fPath & folder & folder2 & fileName)
         Do Until rss.EOF
             fileName = rss.Fields(0).Value & ".txt"             'moved
             FullPath = fPath & folder & folder2 & fileName      'moved
             fName2 = Dir(fPath & folder & folder2 & fileName)   'moved
             If fName2 = "" Then
                 Dim x As Integer
                 x = FreeFile
                 Open FullPath For Append As #x
                 Dim sName As String
                 Dim sSSN As String
                 Dim sENum As String
                 sName = rss.Fields(0).Value
                 sSSN = "Social Security Number: " & rss.Fields(1).Value
                 sENum = "Employee Number: " & rss.Fields(2).Value
                 Write #x, sName & vbCrLf & sSSN & vbCrLf & sENum & vbCrLf
                 Close #x
                 rss.MoveNext
             End If
         Loop
     End If
     rss.Close
     Set rss = Nothing
     Set cmm = Nothing
     cnn.Close
     Set cnn = Nothing
     Exit Sub
End Sub


However, I'd rewrite the above to make it readable.

Oops, what was I thinking...?

Public Sub CreateEmployeeFiles()

     Dim sAppPath As String
     Dim sFolder1 As String
     Dim sFolder2 As String
     Dim sFolder As String

     sAppPath = App.Path
     sFolder1 = "\Pay Period\"
     sFolder2 = "Current\"

     sFolder = sAppPath & sFolder1 & sFolder2

     If Dir(sFolder, vbDirectory) = "" Then
         Debug.Print "Create folder: " & sFolder
         MsgBox sFolder, vbExclamation, "Missing folder..."
         Exit Sub
     End If

     Dim sName As String
     Dim sSSN As String
     Dim sENum As String

     Dim sFullPath As String
     Dim sFilename As String

     Dim cnn As ADODB.Connection
     Dim cmd As ADODB.Command
     Dim rst As ADODB.Recordset

     Set cnn = New ADODB.Connection
     cnn.Open gsConnection

     Set cmd = New ADODB.Command
     With cmd
         .ActiveConnection = cnn
         .CommandText = "SELECT * FROM Employees;"
         .CommandType = adCmdText
     End With

     Set rst = New ADODB.Recordset
     With rst
         .CursorType = adOpenStatic
         .CursorLocation = adUseClient
         .LockType = adLockOptimistic
         .Open cmd

         If .BOF And .EOF Then
             Debug.Print "No records in database"
             Debug.Assert False
         Else
             Do Until .EOF
                 sName = .Fields("Employee_Name").Value & ""
                 sSSN = .Fields("Social_Security_Number").Value & ""
                 sENum = .Fields("Employee_Number").Value & ""

                 sFilename = sName & " " & sENum & ".txt"

                 sFullPath = sFolder & sFilename

                 If Dir(sFullPath) = "" Then     'if file doesn't exist
                     sSSN = "Social Security Number: " & sSSN
                     sENum = "Employee Number: " & sENum

                     Call AppendToFile(sFullPath, sName & vbCrLf & sSSN 
& vbCrLf & sENum & vbCrLf)
                 End If

                 .MoveNext
             Loop
         End If

         .Close
     End With

     Set rst = Nothing

     Set cmd = Nothing

     cnn.Close
     Set cnn = Nothing

End Sub

Public Sub AppendToFile(ByVal sFilename As String, ByVal sText As String)
     Dim i As Integer

     i = FreeFile
     Open sFilename For Append As #i
     'Write #i, sText
     Print #i, sText
     Close #i
End Sub


I've used employee_name & " " & employee_number for the filename - to 
cope with those who have the same name.

You may also find Print preferable to Write.


However, in reality, I'm more likely to use something like...

Public Sub CreateEmployeeFiles()

     Dim sAppPath As String
     Dim sFolder1 As String
     Dim sFolder2 As String
     Dim sFolder As String

     sAppPath = App.Path
     sFolder1 = "\Pay Period\"
     sFolder2 = "Current\"

     sFolder = sAppPath & sFolder1 & sFolder2

     If Dir(sFolder, vbDirectory) = "" Then
         Debug.Print "Create folder: " & sFolder
         MsgBox sFolder, vbExclamation, "Missing folder..."
         Exit Sub
     End If

     Dim sName As String
     Dim sSSN As String
     Dim sENum As String

     Dim sFullPath As String
     Dim sFilename As String

     Dim sSQL As String
     Dim rst As ADODB.Recordset

     sSQL = "SELECT * FROM Employees;"

     Set rst = GetAdoRecordset(gsConnection, sSQL)
     With rst
         If .BOF And .EOF Then
             Debug.Print "No records in database"
             Debug.Assert False
         Else
             Do Until .EOF
                 sName = .Fields("Employee_Name").Value & "" 'append 
empty string in case of null
                 sSSN = .Fields("Social_Security_Number").Value & ""
                 sENum = .Fields("Employee_Number").Value & ""

                 sFilename = sName & " " & sENum & ".txt"

                 sFullPath = sFolder & sFilename

                 If Dir(sFullPath) = "" Then     'if file doesn't exist
                     sSSN = "Social Security Number: " & sSSN
                     sENum = "Employee Number: " & sENum

                     Call AppendToFile(sFullPath, sName & vbCrLf & sSSN 
& vbCrLf & sENum & vbCrLf)
                 End If

                 .MoveNext
             Loop
         End If

         .Close
     End With

     Set rst = Nothing

End Sub


That's a bit simpler, don't you think?

Annoyingly, I've left the writing of the GetAdoRecordset function as an 
exercise for the reader. :-)

HTH

Thread

Re: Renaming a Directory in VB6???? "jason@smkzone.com" <jbodine1@yahoo.com> - 2011-02-03 04:20 -0800
  Re: Renaming a Directory in VB6???? "jason@smkzone.com" <jbodine1@yahoo.com> - 2011-02-03 14:27 -0800
    Re: Renaming a Directory in VB6???? Steve Rindsberg <steve@rdpslides.com> - 2011-02-11 16:41 -0500
    Re: Renaming a Directory in VB6???? GS <gs@somewhere.net> - 2011-02-04 13:41 -0500
      Re: Renaming a Directory in VB6???? "jason@smkzone.com" <jbodine1@yahoo.com> - 2011-02-05 04:57 -0800
    Re: Renaming a Directory in VB6???? "jason@smkzone.com" <jbodine1@yahoo.com> - 2011-02-04 10:31 -0800
    Re: Renaming a Directory in VB6???? "Bob Butler" <bob_butler@cox.invalid> - 2011-02-03 15:23 -0800
      Re: Renaming a Directory in VB6???? "David Youngblood" <dwy@flash.net> - 2011-02-04 05:44 -0600
      Re: Renaming a Directory in VB6???? "jason@smkzone.com" <jbodine1@yahoo.com> - 2011-02-03 22:22 -0800
    Re: Renaming a Directory in VB6???? Jason Keats <jkeats@melbpcDeleteThis.org.au> - 2011-02-04 23:33 +1100
  Re: Renaming a Directory in VB6???? "jason@smkzone.com" <jbodine1@yahoo.com> - 2011-02-03 04:47 -0800

csiph-web