UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Split Database Now VBA Import Files And Directories Won't Work, Access 2016    
 
   
Oblio
post Jan 10 2018, 11:12 AM
Post#1



Posts: 168
Joined: 5-February 15



Just wondering if there is a way to be able to modify an existing collection of VBA code which worked perfectly prior to splitting the database. Is this still doable in VBA ?

I can post the code, but thought I would ask first. If there are any tutorials, samples or help available I would be very thankful !

Bill iconfused.gif
Go to the top of the page
 
theDBguy
post Jan 10 2018, 11:17 AM
Post#2


Access Wiki and Forums Moderator
Posts: 71,420
Joined: 19-June 07
From: SunnySandyEggo


Hi Bill,

Can you give us at least one example how splitting the database affected the VBA code? Thanks.

--------------------
Just my 2 cents... "And if I claim to be a wise man, it surely means that I don't know" - Kansas
Microsoft Access MVP | Access Website | Access Blog | Email
Go to the top of the page
 
RuralGuy
post Jan 10 2018, 11:19 AM
Post#3


UtterAccess VIP
Posts: 2,801
Joined: 25-June 05
From: @ 8300' in the Colorado Rocky Mountains


I'm not sure what you need but confused by your request. Your code should still work after splitting. Would you post an example of code that no longer works?

Oops, a little slow posting. smile.gif

--------------------
(RG for short) aka Allan Bunch Previous MS Access MVP acXP, ac07, ac10, ac13 - WinXP Pro, Win7 Pro, Win10 Pro
Please reply to the forum so all may benefit.
Go to the top of the page
 
GroverParkGeorge
post Jan 10 2018, 11:26 AM
Post#4


UA Admin
Posts: 31,611
Joined: 20-June 02
From: Newcastle, WA


One more request for clarification, please.

What does it mean to say "it won't work"? Does that mean it raises an error? Does that mean it does nothing? Does that mean the "wrong thing" happens instead of what you expect?

--------------------
Go to the top of the page
 
Oblio
post Jan 10 2018, 12:59 PM
Post#5



Posts: 168
Joined: 5-February 15



Yes, of course... I thought it might only be a matter of direction to a tutorial...

So, the error is "Runtime Error 3219, Invalid Operation". I believe, from what I can find, you cannot use a linked table with dbOpenTable... I tried to change it to dbOpenDynaset, but that caused
the line after to be highlighted.

I did not write the code and so really am not sure how to fix this...

I have placed asterisks in front and behind the line highlighted in the code. Here is the full code:

CODE
'Allen Browne -- was called 'ListFiles'
'modified by Crystal
Public Function ListFilesToTable( _
   pPath As String _
    , Optional pFileSpec As String = "*.pdf" _
    , Optional pIncludeSubfolders As Boolean = False _
    ) As Byte


'On Error GoTo Proc_Err
    'Purpose:   List the files in the path.
    'Arguments: pPath = the path to search.
    '           pfileSpec = "*.*" unless you specify differently.
    '           pIncludeSubfolders: If True, returns results from subdirectories of pPath as well.
    'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
            
   Dim mRunStartTime As Date _
      , mSeconds As Long _
      , mMin As Long _
      , mMsg As String _
      , mNumFiles As Long _
      , mFileSizes As Long _
      , S As String
      
   mRunStartTime = Now()
   gNumFilRun = 0
  
   '--------

   VarX = DLookup("[User_Logs_ID]", "[This_Machine_q_Current_User]")
        
  
    Set db = CurrentDb
   Set r = db.OpenRecordset("t_Runs", dbOpenDynaset)
  
   r.AddNew
   r!StartPath = pPath
   r!User_Logs_ID_FK = VarX
   r.Update
   r.Bookmark = r.LastModified
  
   gRunID = r!Runs_ID
   r.Close
  
  
   Set fso = CreateObject("Scripting.FileSystemObject")
  
   Set r = db.OpenRecordset("t_Files", dbOpenDynaset)
   Set rDir = db.OpenRecordset("t_Directories", dbOpenDynaset)
  ***** Set rDir2 = db.OpenRecordset("t_Directories", dbOpenTable)*****
   rDir2.Index = "PrimaryKey"

   Set rTypes = db.OpenRecordset("lt_File_Types", dbOpenTable)
   rTypes.Index = "fType"
  
   Call FillDirToTable(pPath, pFileSpec, pIncludeSubfolders)
      
   r.Close
   Set r = db.OpenRecordset("t_Runs", dbOpenDynaset)
   r.MoveLast
   r.Edit
   r!Run_End_Time = Now()
   r!Number_Of_Files_In_This_Run = gNumFilRun
   r.Update
  
   S = "INSERT INTO t_Directories ( Directories_ID, NumDirs, SizePath, NumFilPath ) " _
      & " SELECT D.Directories_ID " _
      & " , Count(d2.Directories_ID) " _
      & " , Sum(d2.SizeDir) " _
      & " , Sum(d2.NumFilDir) " _
      & " FROM Directories AS D, Directories AS d2 " _
      & " WHERE (Left([d2].[FPath], Len([D].[FPath])) = [D].[FPath]) " _
      & " AND D.RunID=" & gRunID _
      & " GROUP BY D.RunID, D.DirID;"
   rSql S
  
   mSeconds = DateDiff("s", mRunStartTime, Now())
  
   mMin = mSeconds \ 60
   If mMin > 0 Then
      mMsg = mMin & " min "
      mSeconds = mSeconds - (mMin * 60)
   Else
      mMsg = ""
   End If
  
   mMsg = mMsg & mSeconds & " seconds"
  
   MsgBox "Added " & Format(gNumFilRun, "#,###") & " files from: " _
      & vbCrLf & vbCrLf & pPath _
      & vbCrLf & vbCrLf & " for file specification --> " & pFileSpec _
      & vbCrLf & vbCrLf & mMsg, , "Done"
  Call PlayIt
Proc_Exit:
   SysCmd acSysCmdClearStatus
    
   If Not r Is Nothing Then
      r.Close
      Set r = Nothing
   End If
   If Not rTypes Is Nothing Then
      rTypes.Close
      Set rTypes = Nothing
   End If
   If Not rDir Is Nothing Then
      rDir.Close
      Set rDir = Nothing
   End If
   If Not rDir2 Is Nothing Then
      rDir2.Close
      Set rDir2 = Nothing
   End If
  
   Set db = Nothing
   Set fso = Nothing
  
    Exit Function

Proc_Err:
    MsgBox "Error " & Err.Number & ": " & Err.Description, , "ERROR"
    
    'remove next line after debugged
    'Stop: Resume
    
    Resume Proc_Exit
End Function

Private Function FillDirToTable( _
     ByVal pFolder As String _
    , ByVal pFileSpec As String _
    , ByVal bIncludeSubfolders As Boolean _
    ) As Long
    
    'RETURNS Directories_ID
    
    'On Error GoTo Proc_Err
    
    DoEvents
    
    Dim mFilename As String _
      , mFilePathName As String _
      , vFolderName As Variant _
      , mAttr As Long _
      , mPos As Integer _
      , mStr As String _
      , mErrNo As Long _
      , mPart As String _
      , mDirID As Long _
      , mDirIDPath As Long _
      , mNumFiles As Long _
      , mSizeDir As Long
    
   Dim colFolders As New Collection

   'Add the files to the folder.
   pFolder = TrailingSlash(pFolder)
   Debug.Print pFolder
  
   rDir.AddNew
   rDir!Runs_ID_FK = gRunID
   If Len(pFolder) > 255 Then
      rDir!Gt255 = True
      rDir!pFolder = Left(pFolder, 255)
   Else
      rDir!FPath = pFolder
   End If
      
   rDir.Update
   rDir.Bookmark = rDir.LastModified
   mDirID = rDir!Directories_ID
   FillDirToTable = mDirID
  
   mFilename = dir(pFolder & pFileSpec)

   mNumFiles = 0
   mSizeDir = 0

    Do While mFilename <> vbNullString
      mPart = "0"
      mErrNo = 0
      
      SysCmd acSysCmdSetStatus, gNumFilRun
      Debug.Print gNumFilRun;
      
      mFilePathName = pFolder & mFilename
      
      mPart = "A"
      r.AddNew
      r!FName = mFilename
      r!Directories_ID = mDirID
      r!FDateTime = FileDateTime(mFilePathName)
      r!FSize = FileLen(mFilePathName)
      
      mSizeDir = mSizeDir + FileLen(mFilePathName)
      mNumFiles = mNumFiles + 1
      
      mAttr = GetAttr(mFilePathName)
      '---------- attributes
      r!FAttr = mAttr
      r!fAlias = (mAttr And 1024)
      r!fArchive = (mAttr And 32)
      r!fCompressed = (mAttr And 2048)
      r!fDirectory = (mAttr And 16)
      r!fHidden = (mAttr And 2)
      r!fNormal = (mAttr And 0)
      r!fReadOnly = (mAttr And 1)
      r!fSystem = (mAttr And 4)
      r!fVolume = (mAttr And 8)
      
      '---------- fso info
      With fso.GetFile(mFilePathName)
         r!FDateCr = .DateCreated
         r!FDateMod = .DateLastModified
         r!FDateAcc = .DateLastAccessed
         mStr = Nz(.Type, "")
      End With
      
      '---------- file extension
      mPos = InStrRev(mFilename, ".")
      If mPos > 0 Then
         r!fExt = Mid(mFilename, mPos + 1, Len(mFilename) - mPos)
      End If
      
      '---------- file type
      If Len(mStr) > 0 Then
         'rTypes.FindFirst "fType= '" & mStr & "'"
         rTypes.Seek "=", mStr
         If rTypes.NoMatch Then
            rTypes.AddNew
            rTypes!fType = mStr
            rTypes.Update
            rTypes.Bookmark = rTypes.LastModified
         End If
         r!File_Types_ID_FK = rTypes!File_Types_ID
      End If
      
WriteError:
      gNumFilRun = gNumFilRun + 1
      
      If mErrNo <> 0 Then
         r!ErrNum = mErrNo
      End If
      
      r.Update
        
         '--------
'If gNumFilRun > 100 Then GoTo Proc_Exit
NextFile:
         If mSizeDir <> 0 Then
            rDir.Bookmark = rDir.LastModified
            rDir.Edit
            rDir!NumFilDir = mNumFiles
            rDir!SizeDir = mSizeDir
            rDir.Update
         End If

        mFilename = dir
    Loop
  
   DoEvents
  
   mPart = "B"
   If bIncludeSubfolders Then
       'Build collection of additional subfolders.
       mFilename = dir(pFolder, vbDirectory)
       Do While mFilename <> vbNullString
           If (mFilename <> ".") And (mFilename <> "..") Then
               If (GetAttr(pFolder & mFilename) And vbDirectory) <> 0& Then
                   colFolders.Add mFilename
               End If
           End If
           mFilename = dir
       Loop
      
       DoEvents
      
      mPart = "C"
       For Each vFolderName In colFolders
'         mNumFilPath = 0
'         mSizePath = 0
         mDirIDPath = FillDirToTable(pFolder & TrailingSlash(vFolderName), pFileSpec, True)
'         rDir2.Seek "=", mDirIDPath
'         If Not rDir2.NoMatch Then
'            r.Edit
'            rDir2!NumFilPath = mNumFilPath
'            rDir2!SizePath = mSizePath
'            r.Update
'         End If
       Next vFolderName
   End If

Proc_Exit:
    
    Exit Function

Proc_Err:
   mErrNo = Err.Number
   If mPart = "0" Then
      
      r.AddNew
      r!DirID = mDirID
      r!FName = mFilename
      r!ErrNum = mErrNo
      r.Update
   ElseIf mPart = "A" And mErrNo = 53 Then
      GoTo WriteError
   Else
      Resume Next
   End If
  
'  If Err.Number = 53 Then Resume NextFile
'   If Err.Number = 53 Then Resume Next
      
   MsgBox Err.Description, , "ERROR " & Err.Number
  
   Stop:
   Resume Next
  
   Resume Proc_Exit
   Resume
End Function


Thank you for looking at this code and for any help you may offer...

Hope you are having a great day !

Bill
Go to the top of the page
 
Oblio
post Jan 10 2018, 01:05 PM
Post#6



Posts: 168
Joined: 5-February 15



Thanks, Rural Guy, for responding... I attached the code in a post above...

Bill
This post has been edited by Oblio: Jan 10 2018, 01:06 PM
Go to the top of the page
 
Oblio
post Jan 10 2018, 01:08 PM
Post#7



Posts: 168
Joined: 5-February 15



Hi,

Thanks very much for responding !

I have posted the code below in another reply to avoid duplication... I hope that is ok?

Bill
Go to the top of the page
 
theDBguy
post Jan 12 2018, 11:43 AM
Post#8


Access Wiki and Forums Moderator
Posts: 71,420
Joined: 19-June 07
From: SunnySandyEggo


Hi Bill,

So what happens if you change it to dbOpenDynaset and comment out the next (Index) line?

--------------------
Just my 2 cents... "And if I claim to be a wise man, it surely means that I don't know" - Kansas
Microsoft Access MVP | Access Website | Access Blog | Email
Go to the top of the page
 


Custom Search
RSSSearch   Top   Lo-Fi    19th January 2018 - 10:35 PM