Link to home
Start Free TrialLog in
Avatar of titorober23
titorober23

asked on

copy form and module

H
I copied a form and a module to another database, but for somereason is not working in the new database, i check the names and everyting ios the same as the original.
The only difference between the original database and the new one, is that in the new one is a split database, which i already split the new tables that i copied.
Anything else that i can check or change to make it work?
any idea?

Option Compare Database
Option Explicit
 
Public Function ProcessFileImport(ByVal sFile As String, ByVal sTable As String) As String
   On Error GoTo ProcessFileImport_Error
   
   ' Excel object variables
   Dim appExcel As Excel.Application
   Dim wbk As Excel.Workbook
   Dim wks As Excel.Worksheet
   
   ' Access object variables
   Dim dbs As DAO.Database
   Dim rstRead As DAO.Recordset
   Dim rstWrite As DAO.Recordset
   Dim fld As DAO.Field
   
   ' Declared variables
   Dim bytWks As Byte
   Dim bytMaxPages As Byte
   Dim intStartRow As Integer
   Dim strData As String
   Dim intMaxRow As Integer
   Dim strSQL As String
   Dim strMsg As String
   Dim intLastCol As Integer
   Dim intRow As Integer
   Dim intRec As Integer
   Dim strCurrFld As String
   Dim intCol As Integer
   Dim intLen As Integer
   Dim varValue As Variant
   Dim lngErrs As Long
 
   Const cPassword As String = "xxx999"
   
   DoCmd.Hourglass True
   
   ' Create the Excel Applicaiton, Workbook and Worksheet and Database object
   Set appExcel = Excel.Application
   Set wbk = appExcel.Workbooks.Open(sFile)
   Set dbs = CurrentDb
   
   ' Optionally, you can protect / unprotect with a password
   'wkb.Unprotect (cPassword)
   
   ' You could loop through sheets, but for this example, we'll just do one.
   bytMaxPages = 1
   
   ' Sometimes there is header info, so the "Start Row" isn't the first one.
   ' Set this variable to the first row that contains actual data.
   intStartRow = 2
   PostMessage "Opening file: " & sFile
   
   For bytWks = 1 To bytMaxPages
      ' Initialize variables on each pass
      Set wks = Nothing
      Set rstRead = Nothing
      intRow = intStartRow
      
      ' Load current worksheet.  Find used range to determine row count.
      Set wks = appExcel.Worksheets(bytWks)
      
      ' Optionally, you can protect / unprotect with a password
      'wks.Unprotect (cPassword)
      
      ' You need to figure out how many rows this sheet contains, so to know
      ' how far down to read.  That value is saved in intMaxRow
      strData = wks.UsedRange.Address
      intMaxRow = CInt(Mid(strData, InStrRev(strData, "$")))
      'intMaxRow = CInt(Mid(strData, LastInStr(strData, "$")))
      
      strData = ""
      
      ' Go get the list of fields for this worksheet from the Field Map table
      strSQL = "SELECT [AccessField], [OrdinalPosition] FROM ImportColumnSpecs " & _
               "WHERE [ImportName]='" & sTable & "' ORDER BY [OrdinalPosition] ASC;"
      Set rstRead = dbs.OpenRecordset(strSQL, dbOpenDynaset)
      
      ' If there is a mistake and no specification exists, then exit with message
      If rstRead.BOF And rstRead.EOF Then
         strMsg = "The import spec was not found.  Cannot continue."
         MsgBox strMsg, vbExclamation, "Error"
      Else
         rstRead.MoveLast
         rstRead.MoveFirst
         intLastCol = rstRead.RecordCount
         
         ' The name of the import and destination table should be the same for this
         ' code to function correctly.
         Set rstWrite = dbs.OpenRecordset(sTable, dbOpenDynaset)
         Do Until intRow > intMaxRow
            ' Check row to be sure it is not blank.  If so, skip the row
            For intCol = 1 To intLastCol
               strData = strData & Trim(Nz(wks.Cells(intRow, intCol), ""))
            Next
            
            If strData = "" Then
               intRow = intRow + 1
            Else
               intRec = intRec + 1
               PostMessage "Processing record " & intRec & ".  {StoreID=" & wks.Cells(intRow, 1) & "}"
               rstWrite.AddNew
               Do Until rstRead.EOF
                  ' Loop through the list of fields, processing them one at a time.
                  ' Grab the field name to simplify code and improve performance.
                  strCurrFld = Nz(rstRead!AccessField, "")
                  intCol = rstRead!OrdinalPosition
                  
                  ' Make sure that text fields truncate data at prescribed limits.
                  ' Users may not enter supply more text than the fields can contain.
                  If dbs.TableDefs(sTable).Fields(strCurrFld).Type = dbText Then
                     intLen = dbs.TableDefs(sTable).Fields(strCurrFld).Size
                     varValue = Left(Nz(wks.Cells(intRow, intCol), ""), intLen)
                  Else
                     varValue = wks.Cells(intRow, intCol)
                  End If
                  
                  ' The database schema requires that empty fields contain NULL, not
                  ' the empty string.
                  If varValue = "" Then varValue = Null
                  
                  ' Handle date columns.  Sometimes Excel doesn't format them as dates
                  If InStr(1, strCurrFld, "Date") > 0 Then
                     If Not IsDate(varValue) Then
                        If IsNumeric(varValue) Then
                           On Error Resume Next
                           varValue = CDate(varValue)
                           If Err.Number <> 0 Then
                              ' Can't figure out the date.  Set to null
                              varValue = Null
                              Err.Clear
                           End If
                           On Error GoTo ProcessFileImport_Error
                        Else
                           lngErrs = lngErrs + 1
                           varValue = Null
                        End If
                     End If
                     rstWrite.Fields(strCurrFld) = varValue
                  Else
                     ' If not a date field, then just write the value to the rst
                     rstWrite.Fields(strCurrFld) = varValue
                  End If
                  
                  rstRead.MoveNext
               Loop
               If Not rstRead.BOF Then rstRead.MoveFirst
                              
               rstWrite.Update
               
               ' Reset the variables for processing of the next record.
               strData = ""
               intRow = intRow + 1
               'Debug.Print intRow
            End If
         Loop
         Set wks = Nothing
      End If
   Next
   
Exit_Here:
   ' Report results
   strMsg = "Total of " & intRow & " records imported."
   PostMessage strMsg
   ProcessFileImport = strMsg
   ' Cleanup all objects  (resume next on errors)
   
   On Error Resume Next
   ' Optionally, you can protect / unprotect with a password
   'wkb.Protect (cPassword)
   'wks.Protect (cPassword)
   Set wks = Nothing
   wbk.Close True
   Set wbk = Nothing
   appExcel.Quit
   Set appExcel = Nothing
   Set rstRead = Nothing
   Set rstWrite = Nothing
   Set dbs = Nothing
   DoCmd.Hourglass False
   Exit Function
   
ProcessFileImport_Error:
   MsgBox Err.Description, vbExclamation, "Error"
   Resume Exit_Here
   
End Function
 
Private Sub PostMessage(ByVal sMsg As String)
On Error Resume Next
   If IsLoaded("frmImport1") Then
      Forms!frmImport1!lblMsg.Caption = sMsg
      Forms!frmImport1.Repaint
   End If
End Sub
 
Public Function IsLoaded(ByVal sForm As String) As Boolean
On Error Resume Next
 
'/////////////////////////////////////////////
'
' Returns True if the specified form is open
' in Form view or Datasheet view.
'
'/////////////////////////////////////////////
 
Const conObjStateClosed = 0
Const conDesignView = 0
    
    If SysCmd(acSysCmdGetObjectState, acForm, sForm) <> conObjStateClosed Then
        If Forms(sForm).CurrentView <> conDesignView Then
            IsLoaded = True
        End If
    End If
    
End Function
 
Public Function LastInStr(sText As String, sFind As String) As Integer
On Error Resume Next
 
'//////////////////////////////////////////////////////////////////////////
'
' This function finds the last instance of a character within
' a string of characters and returns an integer representing
' the final position of the desired character.
'
' Typically, this function us used to find the final "\" in
' a file path string
'
'//////////////////////////////////////////////////////////////////////////
 
Dim intCurrVal As Integer
Dim intLastPosition As Integer
    
    intCurrVal = InStr(sText, sFind)
    Do Until intCurrVal = 0
        intLastPosition = intCurrVal
        intCurrVal = InStr(intLastPosition + 1, sText, sFind)
    Loop
    LastInStr = intLastPosition
 
End Function

Open in new window

Avatar of Arthur_Wood
Arthur_Wood
Flag of United States of America image

when you say "some reason is not working in the new database", how are you aware that it is not working?  Are there error messages, or does it just not create the same end result?  Have you stepped through the code, to see what is happening, line by line?
 
AW
Avatar of titorober23
titorober23

ASKER

Yes i step line by line through the code, this is an import process, it just delete the record in the target table, but does not import, it looks like in the line that call a public function, stops, but it does not give me any error, it just does not do anything.
if you provide me your email address i can email you tha database so you can take a look at it.
I am trying to upload a zip file with all the code, but i got a message that .accdb extension is not supported
I made some changes and now is working,  i do not know why
this code was working in my original database
   Dim appExcel As Excel.Application
   Dim wbk As Excel.Workbook
   Dim wks As Excel.Worksheet
and in the new one i had to declare as Object
Now is working
rather than emailing me the database, simply attach the mdb as a file to this site.  That way, others can contribute to the discussion.
ASKER CERTIFIED SOLUTION
Avatar of Arthur_Wood
Arthur_Wood
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Glad to be of assistance.  Hope you now understand about Early and Late binding, and when is a good time to use Late Binding.

AW