![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
Microsoft 365 e Office | Access | Per la casa | Windows
Una famiglia di sistemi di gestione per database relazionali di Microsoft progettati per semplificare l'uso.
Ciao Sandro!
Posto di nuovo il codice perché ho l'impressione che non ci siamo capiti riguardo la posizione dei due ScreenUpdating. Se sbaglio, scusami.
Option Compare Database
Option Explicit
#Const DevMode = 0
Public Sub Test4()
Const cstrProc = "Test4"
On Error GoTo ErrH
Dim e As Long
' --- Personalizzare -------------------- >
'
Const cstrXlsFullPath = "D:\Percorso\Test1"
Const cblnShow = False
' --------------------------------------- <
Const cstrXlClass = "Excel.Application"
Const cstrFullName = "<FullName>"
Const cstrCnn = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0" _
& ";Data Source=" & cstrFullName _
& ";Mode=Read;"
Dim dbp As Access.CurrentProject
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
#If DevMode Then
Dim xlApp As Excel.Application
Dim xlWbk As Excel.Workbook
Dim xlWsh As Excel.Worksheet
Dim xlQry As Excel.QueryTable
#Else
Const xlCmdTable = 3
Dim xlApp As Object
Dim xlWbk As Object
Dim xlWsh As Object
Dim xlQry As Object
#End If
Dim blnNotRunning As Boolean
Dim strCnn As String
Dim strTable As String
Dim lngTable As Long
With Application
Set dbp = .CurrentProject
Set dbs = .CurrentDb
End With
strCnn = Replace(cstrCnn, cstrFullName, dbp.FullName)
Debug.Print strCnn
On Error Resume Next
Set xlApp = GetObject(Class:=cstrXlClass)
e = Err.Number
On Error GoTo ErrH
If e Then
blnNotRunning = True
Set xlApp = CreateObject(Class:=cstrXlClass)
End If
With xlApp
If blnNotRunning And cblnShow Then .Visible = True
.ScreenUpdating = False
Set xlWbk = .Workbooks.Add
End With
With xlWbk.Worksheets
.Add Count:=GetTableDefsCount(dbs) - .Count
End With
For Each tdf In dbs.TableDefs
If (tdf.Attributes And dbSystemObject) = False Then
lngTable = lngTable + 1
strTable = tdf.Name
Set xlWsh = xlWbk.Worksheets.Item(lngTable)
With xlWsh
.Name = strTable
Set xlQry = .QueryTables.Add(Connection:=strCnn _
, Destination:=.Range("A1"))
End With
With xlQry
.CommandType = xlCmdTable
.CommandText = strTable
.AdjustColumnWidth = True
.FieldNames = True
.Refresh
.Delete
End With
Set xlQry = Nothing
End If
Next
MsgBox "Fatto!"
ExtP:
On Error Resume Next
Set tdf = Nothing
Set dbs = Nothing
Set dbp = Nothing
With xlApp
.ScreenUpdating = True
.DisplayAlerts = False
End With
xlWbk.Close SaveChanges:=True _
, FileName:=cstrXlsFullPath
If cblnShow Then
xlApp.Visible = True
Else
If blnNotRunning Then xlApp.Quit
End If
Set xlQry = Nothing
Set xlWsh = Nothing
Set xlWbk = Nothing
Set xlApp = Nothing
Exit Sub
ErrH:
With Err
MsgBox "ERR#" & CStr(.Number) _
& vbNewLine & .Description _
, vbOKOnly Or vbCritical, cstrProc
End With
Resume ExtP
End Sub