Private Sub insLoadFormData_Click()
'On Error GoTo Err_insLoadFormData_Click
'show that we are doing work
DoCmd.Hourglass True
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'boolean to determine if we canceled out of the filepicker dialog
Dim boolFileCancel As Boolean
boolFileCancel = False
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path
'of each selected item. Even though the path is a String,
'the variable must be a Variant because For Each...Next
'routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
With fd
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
If .Show = -1 Then
''setup to work with excel
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = New Excel.Application
'Step through each string in the FileDialogSelectedItems collection.
For Each vrtSelectedItem In .SelectedItems
Set xlBook = xlApp.Workbooks.Open(vrtSelectedItem)
''GET SHEET LIST
''this gets the list of excel worksheets to process
Dim strSheetList As String
strSheetList = DLookup("[CONFIG_VALUE]", "[CONFIG]", _
"[CONFIG_TYPE] = ""LOADFORM"" AND [CONFIG_SUBTYPE] = ""STRUCTURE"" AND [CONFIG_NAME] = ""SHEETLIST""")
Dim arrSheetList() As String
arrSheetList = Split(strSheetList, ",")
''GET SHEET LIST
''now loop through the list of worksheets, open them and process them accordingly
Dim intSheetCnt As Integer
For intSheetCnt = LBound(arrSheetList) To UBound(arrSheetList)
''process Facility Info tab
Set xlSheet = xlBook.Worksheets(arrSheetList(intSheetCnt))
Dim stStartCol As String
Dim intStartCol As Integer
Dim stEndCol As String
Dim intEndCol As Integer
Dim stStartRow As String
Dim intStartRow As Integer
Dim stValidationCol As String
Dim intValidationCol As Integer
stStartCol = DLookup("[CONFIG_VALUE]", "[CONFIG]", _
"[CONFIG_TYPE] = ""LOADFORM"" AND [CONFIG_SUBTYPE] = """ & UCase(arrSheetList(intSheetCnt)) & """ AND [CONFIG_NAME] = ""STARTCOL""")
stEndCol = DLookup("[CONFIG_VALUE]", "[CONFIG]", _
"[CONFIG_TYPE] = ""LOADFORM"" AND [CONFIG_SUBTYPE] = """ & UCase(arrSheetList(intSheetCnt)) & """ AND [CONFIG_NAME] = ""ENDCOL""")
stStartRow = DLookup("[CONFIG_VALUE]", "[CONFIG]", _
"[CONFIG_TYPE] = ""LOADFORM"" AND [CONFIG_SUBTYPE] = """ & UCase(arrSheetList(intSheetCnt)) & """ AND [CONFIG_NAME] = ""STARTROW""")
stValidationCol = DLookup("[CONFIG_VALUE]", "[CONFIG]", _
"[CONFIG_TYPE] = ""LOADFORM"" AND [CONFIG_SUBTYPE] = """ & UCase(arrSheetList(intSheetCnt)) & """ AND [CONFIG_NAME] = ""VALIDATIONCOL""")
'MsgBox "startcol: " & stStartCol & " endcol: " & stEndCol & " startrow: " & stStartRow
intStartCol = Asc(UCase(stStartCol))
intEndCol = Asc(UCase(stEndCol))
intStartRow = CInt(stStartRow)
intValidationCol = Asc(UCase(stValidationCol))
'MsgBox "intstartcol: " & intStartCol & " intendcol: " & intEndCol & " intstartrow: " & intStartRow
Dim intCurRow As Integer
Dim intColCnt As Integer
Dim intCurCol As Integer
Dim stRange As String
intCurRow = intStartRow
Dim boolQuit As Boolean
boolQuit = False
Dim gotheaders As Boolean
gotheaders = False
ReDim headers(intEndCol) As String
ReDim values(intEndCol) As String
'If Not FileLocked("c:\text.txt") Then
' Open "c:\text.txt" For Output As #1
'End If
'Dim strLine As String
'Print #1, "===Worksheet: " & arrSheetList(intSheetCnt)
'Print #1, ""
Do While Not boolQuit
For intColCnt = intStartCol To intEndCol
stRange = Chr(intColCnt) & CStr(intCurRow)
If (Not gotheaders) Then
headers(intColCnt) = xlSheet.Range(stRange).Value
' strLine = strLine & xlSheet.Range(stRange).Value & ","
Else
values(intColCnt) = xlSheet.Range(stRange).Value
' strLine = strLine & xlSheet.Range(stRange).Value & ","
End If
Next intColCnt
''do code to validate, generate and insert data into tables
'' validation includes checking to see if we need to quit this loop!
If (Not gotheaders) Then
gotheaders = True
'Print #1, strLine
Else
If (values(intValidationCol) <> "") Then
'Print #1, strLine
''this is where we massage data before INSERT
''doing static sheet names until i can figure out a way to programmatically do this
''the Order-Result Info sheet currently proves a greater challenge beyond allotted time to overcome
Dim boolRETURN As Boolean
Select Case UCase(arrSheetList(intSheetCnt))
Case "FACILITY INFO"
''insert entire row as is for now
boolRETURN = InsertInfoRow(intStartCol, intEndCol, arrSheetList(intSheetCnt), headers(), values())
Case "PATIENT INFO"
''1. generate new MRN for patient
Dim newMRN As String
newMRN = CStr(NextID("MRN"))
''2. update values() array with MRN info
boolRETURN = updInfoArrayCol("MRN", newMRN, headers(), values())
''3. generate new PatientID for patient
Dim newPatientID As String
newPatientID = CStr(NextID("PATIENT"))
''4. make link between generated PatientID and PatientID in load form for order/result linking later
''3. insert row
Case "ORDER-RESULT INFO"
End Select
Else
boolQuit = True
End If
End If
' Print #1, ""
' Print #1, ""
' strLine = ""
''go to the next row
intCurRow = intCurRow + 1
Loop
''for loop through next arrSheetList
Next intSheetCnt
''go through for loop for next selected file if multiple files selected
Next vrtSelectedItem
'The user pressed Cancel.
Else
boolFileCancel = True
End If
End With
'Set the object variable to Nothing.
Set fd = Nothing
'Close #1
Exit_insLoadFormData_Click:
If Not boolFileCancel Then
''don't run these cmds if they cancelled the file dialog
''close everything up
xlApp.ActiveWorkbook.Close
xlApp.Quit
Set xlSheet = Nothing
DoEvents
Set xlBook = Nothing
DoEvents
Set xlApp = Nothing
DoEvents
End If
'show that we are done working
DoCmd.Hourglass False
Exit Sub
Err_insLoadFormData_Click:
MsgBox "insLoadFormData Error: " & vbCrLf & Err.Number & ": " & Err.Description
AddLogEntry "insLoadFormData Error: " & vbCrLf & Err.Number & ": " & Err.Description, "ERROR"
Resume Exit_insLoadFormData_Click
End Sub
