Sub MainMacro()
Dim calculationMode As Integer
calculationMode = Application.Calculation
On Error GoTo Err_Finally
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Do Something......
Exit_Sub:
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = calculationMode
Exit Sub
Err_Finally:
MsgBox Err.Description
Resume Exit_Sub
End Sub
Monday, September 26, 2016
Friday, September 23, 2016
Document Access Database (*.mdb)
Public Sub DocumentDatabase()
Dim path As String
path = Application.CurrentProject.path & "\" + Replace(Application.CurrentProject.Name, ".mdb", "") + "\"
On Error Resume Next
Kill path & "Forms\*.*"
Kill path & "Reports\*.*"
Kill path & "Macros\*.*"
Kill path & "Modules\*.*"
Kill path & "Queries\*.*"
On Error GoTo Err_DocDatabase
Dim dbs As Database
Dim cnt As Container
Dim doc As Document
Dim i As Integer
Set dbs = CurrentDb() ' use CurrentDb() to refresh Collections
Set cnt = dbs.Containers("Forms")
For Each doc In cnt.Documents
Application.SaveAsText acForm, doc.Name, path & "Forms\" & doc.Name & ".frm"
Next doc
Set cnt = dbs.Containers("Reports")
For Each doc In cnt.Documents
Application.SaveAsText acReport, doc.Name, path & "Reports\" & doc.Name & ".rpt"
Next doc
Set cnt = dbs.Containers("Scripts")
For Each doc In cnt.Documents
Application.SaveAsText acMacro, doc.Name, path & "Macros\" & doc.Name & ".vbs"
Next doc
Set cnt = dbs.Containers("Modules")
For Each doc In cnt.Documents
Application.SaveAsText acModule, doc.Name, path & "Modules\" & doc.Name & ".bas"
Next doc
'Dim obj As Object
'For Each obj In Application.CurrentData.AllTables
'Application.ExportXML acExportQuery, obj.Name, , path & "Tables\" & obj.Name & ".xsd"
'Next
For i = 0 To dbs.QueryDefs.Count - 1
Application.SaveAsText acQuery, dbs.QueryDefs(i).Name, path & "Queries\" & dbs.QueryDefs(i).Name & ".sql"
Next i
'For i = 0 To dbs.TableDefs.Count - 1
' Application.ExportXML acExportTable, dbs.TableDefs(i).Name, , path & "Tables\" & dbs.TableDefs(i).Name & ".xsd"
'Next i
Set doc = Nothing
Set cnt = Nothing
Set dbs = Nothing
MsgBox "Done"
Exit_DocDatabase:
Exit Sub
Err_DocDatabase:
Select Case Err
Case Else
MsgBox Err.Description
Resume Exit_DocDatabase
End Select
End Sub
Dim path As String
path = Application.CurrentProject.path & "\" + Replace(Application.CurrentProject.Name, ".mdb", "") + "\"
On Error Resume Next
Kill path & "Forms\*.*"
Kill path & "Reports\*.*"
Kill path & "Macros\*.*"
Kill path & "Modules\*.*"
Kill path & "Queries\*.*"
On Error GoTo Err_DocDatabase
Dim dbs As Database
Dim cnt As Container
Dim doc As Document
Dim i As Integer
Set dbs = CurrentDb() ' use CurrentDb() to refresh Collections
Set cnt = dbs.Containers("Forms")
For Each doc In cnt.Documents
Application.SaveAsText acForm, doc.Name, path & "Forms\" & doc.Name & ".frm"
Next doc
Set cnt = dbs.Containers("Reports")
For Each doc In cnt.Documents
Application.SaveAsText acReport, doc.Name, path & "Reports\" & doc.Name & ".rpt"
Next doc
Set cnt = dbs.Containers("Scripts")
For Each doc In cnt.Documents
Application.SaveAsText acMacro, doc.Name, path & "Macros\" & doc.Name & ".vbs"
Next doc
Set cnt = dbs.Containers("Modules")
For Each doc In cnt.Documents
Application.SaveAsText acModule, doc.Name, path & "Modules\" & doc.Name & ".bas"
Next doc
'Dim obj As Object
'For Each obj In Application.CurrentData.AllTables
'Application.ExportXML acExportQuery, obj.Name, , path & "Tables\" & obj.Name & ".xsd"
'Next
For i = 0 To dbs.QueryDefs.Count - 1
Application.SaveAsText acQuery, dbs.QueryDefs(i).Name, path & "Queries\" & dbs.QueryDefs(i).Name & ".sql"
Next i
'For i = 0 To dbs.TableDefs.Count - 1
' Application.ExportXML acExportTable, dbs.TableDefs(i).Name, , path & "Tables\" & dbs.TableDefs(i).Name & ".xsd"
'Next i
Set doc = Nothing
Set cnt = Nothing
Set dbs = Nothing
MsgBox "Done"
Exit_DocDatabase:
Exit Sub
Err_DocDatabase:
Select Case Err
Case Else
MsgBox Err.Description
Resume Exit_DocDatabase
End Select
End Sub
Subscribe to:
Posts (Atom)