Torna al Thread
Private Sub Comando0_Click()
Dim Finestra As FileDialog
Dim valore, vrtSelectedItem
Dim DBCorrente As DAO.Database
Dim rsRil As DAO.Recordset
Dim rsRilRisc As DAO.Recordset
Dim rsMis As DAO.Recordset
'selezione dei file excel da importare
Set Finestra = Application.FileDialog(msoFileDialogOpen) 'Equivale a 1
'Titolo ...
Finestra.Title = "Testo Apri"
'Filtri di Ricerca
Finestra.Filters.Clear
Finestra.Filters.Add "Excel", "*.xls", 1
'Selezione Multipla
Finestra.AllowMultiSelect = True
'Apri Finestra
valore = Finestra.Show
If valore = 0 Then
Exit Sub
End If
'Apertura Tabella
Set DBCorrente = CurrentDb
Set rsRil = DBCorrente.OpenRecordset("TRilievi")
Set rsRilRisc = DBCorrente.OpenRecordset("TRilieviRischi")
Set rsMis = DBCorrente.OpenRecordset("TMisurazioni")
'CREAZIONE FILE DI LOG
Dim fs As Variant
Dim log As Variant
Dim punto As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set log = fs.CreateTextFile("\\Filesys01\g_spp1\RUMORE\FileLog.txt", True) 'creazione del file di log
log.writeline ("---- FILE DI LOG ----------- " & Date & " ----- " & Time & "-------------------------------------------------------------------------------------------") 'inserimento di testo nel file di log
log.writeline (" ")
Dim tInizio As Single, tFine As Single, min As Integer, sec As Single 'variabili per calcolare il tempo di esecuzione della subroutine
Dim tTrascorso As Single
' Ottiene ora di inizio.
tInizio = Timer
'Estrazione Dati
For Each vrtSelectedItem In Finestra.SelectedItems
valore = vrtSelectedItem
'Apri file Excels
Dim newBook As Variant
Set newBook = Workbooks.Open(Filename:=valore)
'*********************************************************************************************************
On Error GoTo gestore_errori
'--------------------
'TABELLA RILIEVI
'--------------------
punto = "inizio tabella rilievi" 'serve per tenere traccia del punto in cui si può verificare un errore
'Creazione record
rsRil.AddNew
'Copia nei campi di access il valore delle celle del foglio di excels
punto = "v2"
rsRil.Fields("numScheda") = Excel.Worksheets("I").Range("v2").Value
punto = "y2"
rsRil.Fields("revisione") = Excel.Worksheets("I").Range("y2").Value
punto = "ac2"
rsRil.Fields("codRep") = Excel.Worksheets("I").Range("ac2").Value
punto = "ad2"
rsRil.Fields("codMans") = Excel.Worksheets("I").Range("ad2").Value
punto = "e8"
rsRil.Fields("dataRilievo") = Excel.Worksheets("I").Range("e8").Value
punto = "aa17"
If (Excel.Worksheets("I").Range("aa17").Value) >= 0 Then
rsRil.Fields("lex") = Excel.Worksheets("I").Range("aa17").Value
End If
punto = "ad17"
Dim a As Variant
a = (Excel.Worksheets("I").Range("ad17").Value)
If Not ((Excel.Worksheets("I").Range("ad17").Value) = "") Then
rsRil.Fields("lexAtt") = Excel.Worksheets("I").Range("ad17").Value
End If
punto = "ab17"
If (Excel.Worksheets("I").Range("ab17").Value) >= 0 Then
rsRil.Fields("e") = Excel.Worksheets("I").Range("ab17").Value
End If
'Ricerca del tipo di rilievo
punto = "Ricerca del tipo di rilievo"
Dim str As String
Dim strX As String
strX = "[ X ]"
str = Excel.Worksheets("I").Range("c10").Value
If (StrComp(str, strX)) = 0 Then
rsRil.Fields("tipoRilievo") = Excel.Worksheets("I").Range("d10").Value
punto = "d10"
Else: str = Excel.Worksheets("I").Range("c11").Value
End If
If (StrComp(str, strX)) = 0 Then
rsRil.Fields("tipoRilievo") = Excel.Worksheets("I").Range("d11").Value
punto = "d11"
Else: rsRil.Fields("tipoRilievo") = Excel.Worksheets("I").Range("d12").Value
punto = "d12"
End If
'ricerca del tipo esposizione
punto = "Ricerca del tipo di esposizione"
str = Excel.Worksheets("I").Range("m10").Value
If (StrComp(str, strX)) = 0 Then
rsRil.Fields("tipoEsposizione") = Excel.Worksheets("I").Range("n10").Value
punto = "n10"
Else: rsRil.Fields("tipoEsposizione") = Excel.Worksheets("I").Range("n11").Value
punto = "n11"
End If
strX = "[ X ]" 'la stringa è diversa in quanto presenta due spazi in più
'ricerca rischio ototossico
punto = "Ricerca del rischio ototossico"
str = Excel.Worksheets("I").Range("o29").Value
If (StrComp(str, strX)) = 0 Then
rsRil.Fields("rischioOtotossiche") = True
Else: rsRil.Fields("rischioOtotossiche") = False
End If
'Ricerca dotazione DPI
punto = "Ricerca dotazione DPI"
str = Excel.Worksheets("I").Range("b32").Value
If (StrComp(str, strX)) = 0 Then
punto = "c32"
rsRil.Fields("dotazioneDPI") = Excel.Worksheets("I").Range("c32").Value
Else: str = Excel.Worksheets("I").Range("f32").Value
End If
If (StrComp(str, strX)) = 0 Then
punto = "g32"
rsRil.Fields("dotazioneDPI") = Excel.Worksheets("I").Range("g32").Value
Else: punto = "k32"
rsRil.Fields("dotazioneDPI") = Excel.Worksheets("I").Range("k32").Value
End If
punto = "y36"
rsRil.Fields("valutazione") = Excel.Worksheets("I").Range("y36").Value
punto = "f40"
rsRil.Fields("dataEmissione") = Excel.Worksheets("I").Range("f40").Value
'concatenazione sorgenti
Dim str1 As String
punto = "b17-b22"
str1 = Excel.Worksheets("I").Range("b17").Value
str1 = str1 & " " & Excel.Worksheets("I").Range("b22").Value
rsRil.Fields("sorgente") = str1
rsRil.Fields("nomeFile") = valore
'salvo l'identificativo del rilievo
Dim id As Integer
id = rsRil.Fields("idRilievo")
rsRil.Update
'--------------------
'TABELLA MISURAZIONI
'--------------------
punto = "inizio tabella misurazioni"
Dim i As Integer
i = 17
Do While i < 26
'controllo se è vuoto non ci sono più fasi di lavoro
If (Excel.Worksheets("I").Range(("l" & CStr(i))).Value) = "" Then
Exit Do
End If
rsMis.AddNew
punto = "idRilevo"
rsMis.Fields("idRilievo") = id
punto = "l" & CStr(i)
rsMis.Fields("faseLavoro") = Excel.Worksheets("I").Range(("l" & CStr(i))).Value
punto = "w" & CStr(i)
rsMis.Fields("oreEsposizione") = Excel.Worksheets("I").Range(("w" & CStr(i))).Value
punto = "x" & CStr(i)
rsMis.Fields("minEsposizione") = Excel.Worksheets("I").Range(("x" & CStr(i))).Value
punto = "y" & CStr(i)
rsMis.Fields("la") = Excel.Worksheets("I").Range(("y" & CStr(i))).Value
punto = "z" & CStr(i)
rsMis.Fields("ea") = Excel.Worksheets("I").Range(("z" & CStr(i))).Value
punto = "ac" & CStr(i)
rsMis.Fields("laAtt") = Excel.Worksheets("I").Range(("ac" & CStr(i))).Value
punto = "ae" & CStr(i)
rsMis.Fields("lPicco") = Excel.Worksheets("I").Range(("ae" & CStr(i))).Value
i = i + 1
rsMis.Update
Loop
'---------------------
'TABELLA RilieviRischi
'---------------------
punto = "inizio tabella rilieviRischi"
rsRilRisc.AddNew
rsRilRisc.Fields("idRilievo") = id
punto = "idRilievo Tabella RilieviRischi"
'Ricerca dotazione DPI
str = Excel.Worksheets("I").Range("b29").Value
If (StrComp(str, strX)) = 0 Then
punto = "c29"
rsRilRisc.Fields("RischioVibrazione") = Excel.Worksheets("I").Range("c29").Value
rsRilRisc.Update
str = Excel.Worksheets("I").Range("f29").Value
If (StrComp(str, strX)) = 0 Then
rsRilRisc.AddNew
punto = "g29"
rsRilRisc.Fields("idRilievo") = rsRil.Fields("idRilievo")
rsRilRisc.Fields("RischioVibrazione") = Excel.Worksheets("I").Range("g29").Value
rsRilRisc.Update
End If
Else: str = Excel.Worksheets("I").Range("f29").Value
If (StrComp(str, strX)) = 0 Then
punto = "g29"
rsRilRisc.Fields("RischioVibrazione") = Excel.Worksheets("I").Range("g29").Value
rsRilRisc.Update
Else: punto = "l29"
rsRilRisc.Fields("RischioVibrazione") = Excel.Worksheets("I").Range("l29").Value
rsRilRisc.Update
End If
End If
'Chiudi Excels
'Excel.ActiveWorkbook.Save
Excel.Workbooks.Close
log.writeline (" ")
log.writeline ("importazione dati in " & Chr(34) & valore & Chr(34) & Chr(9) & Chr(9) & Chr(9) & "eseguito" & Chr(9) & Time)
Next vrtSelectedItem
Call fine(log, rsRil, rsMis, rsRilRisc, DBCorrente, tInizio, tFine)
Exit Sub
gestore_errori:
'elimino il record precedentemente inserito per non avere duplicazione di dati
Dim q As String
q = "DELETE TRilievi.*, TRilievi.idRilievo FROM TRilievi WHERE (TRilievi.idRilievo=" & CStr(id) & ");"
DBCorrente.Execute (q)
log.writeline ("-------------------------------------------------------------------------------------------------- ")
log.writeline (" ")
log.writeline ("ARRESTO IMPORTAZIONE " & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Chr(9) & Time)
log.writeline (" ")
log.writeline ("si è verificato un errore in " & Chr(34) & valore & Chr(34) & " Cella: " & punto)
log.writeline (" ")
log.writeline ("tipo di errore: " & Err.Description)
MsgBox ("Attenzione, caricamento interrotto consultare file di log")
Excel.Workbooks.Close
Call fine(log, rsRil, rsMis, rsRilRisc, DBCorrente, tInizio, tFine)
End Sub
'******************************************************************************************************************************************************
Private Sub fine(log As Variant, rsRil As DAO.Recordset, rsMis As DAO.Recordset, rsRilRisc As DAO.Recordset, DBCorrente As DAO.Database, tInizio As Single, tFine As Single)
Dim min As Single
Dim sec As Single
tFine = Timer 'Ottiene ora di fine.
tTrascorso = tFine - tInizio 'tempo trascorso in secondi
min = tTrascorso \ 60 'minuti
sec = tTrascorso - (min * 60) 'secondi
log.writeline (" ")
log.writeline ("tempo impiegato: " & min & " minuti e " & sec & " secondi ")
'Chiusura di tutto
rsRil.Close
rsMis.Close
rsRilRisc.Close
DBCorrente.Close
log.Close
MsgBox ("Operazione conclusa")
End Sub