Option Compare Database
Option Explicit
Public Const ForReading = 1
Public Const ForWriting = 2
Dim dbDATA As Database
Dim tdfLoop As TableDef
Public Sub ListTablesToFile()
Const sFileName = "ListTables.txt"
Dim dbDATA As Database
Dim tdfLoop As TableDef
Dim sResult, sStorePath As String
On Error GoTo ErrorHandler
Set dbDATA = DBEngine.Workspaces(0).Databases(0)
sResult = "Íà äàòó " + Date$ + vbCrLf
' sStorePath = dbDATA.Name
sStorePath = CodeProject.FullName
sStorePath = Left(sStorePath, InStrRev(sStorePath, ".")) + "db.txt"
With dbDATA
sResult = sResult & .TableDefs.Count & " TableDefs in " & .Name + vbCrLf
For Each tdfLoop In .TableDefs
sResult = sResult + " " & tdfLoop.Name + " " & tdfLoop.Connect + vbCrLf
Next tdfLoop
End With
Call SaveToFile(sResult, sStorePath)
MsgBox sStorePath
Exit_Sub:
Exit Sub
ErrorHandler:
MsgBox Error$ & vbCrLf & tdfLoop.Name
Resume Exit_Sub
End Sub
Public Sub ProjectModulesToExport()
Const adVarChar = 200
Const MaxCharacters = 255
Dim sStorePath, sResult, sR2, sModFName As String
Dim FSO As Object
Dim modLoop As Module
Dim i, iC As Integer
Dim obj As AccessObject
Dim dbDATA As DAO.Database
Dim qdfLoop As QueryDef
Dim DataList As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set DataList = CreateObject("ADODB.Recordset")
DataList.Fields.Append "SortName", adVarChar, MaxCharacters
DataList.Open
' ==============================================================
' Ýêñïîðò ìîäóëåé
sStorePath = CodeProject.FullName
sStorePath = Left(sStorePath, InStrRev(sStorePath, ".") - 1) + "_Modules\"
If Not FSO.FolderExists(sStorePath) Then FSO.CreateFolder (sStorePath)
sResult = " Íà äàòó " + Date$ + vbCrLf
sResult = sResult & " " & Application.Modules.Count & " Modules in " & CurrentProject.FullName & vbCrLf
' For i = 0 To Application.Modules.Count - 1
' With Application.Modules(i)
For i = 0 To CurrentProject.AllModules.Count - 1
DoCmd.OpenModule CurrentProject.AllModules(i).Name
With Application.Modules(CurrentProject.AllModules(i).Name)
' sResult = sResult + .Name + vbCrLf
DataList.AddNew
DataList("SortName") = .Name
DataList.Update
sModFName = ReplaceInvalidChars(.Name)
iC = .CountOfLines
If iC = 0 Then iC = 1
sR2 = Application.Modules(i).Lines(1, iC)
Call SaveToFile(sR2, sStorePath + sModFName + ".bas")
End With
Next i
DataList.Sort = "SortName"
DataList.MoveFirst
Do Until DataList.EOF
sResult = sResult & DataList.Fields.Item("SortName") & vbCrLf
DataList.MoveNext
Loop
DataList.Close
Call SaveToFile(sResult, sStorePath + "Candidate.modules.txt")
' ==============================================================
' Ýêñïîðò Ôîðì
DataList.Fields.Append "SortName", adVarChar, MaxCharacters
DataList.Open
sResult = " Íà äàòó " + Date$ + vbCrLf
sResult = sResult & " " & CurrentProject.AllForms.Count & " Forms in " & CurrentProject.FullName & vbCrLf
For i = 0 To CurrentProject.AllForms.Count - 1
With CurrentProject.AllForms(i)
' sResult = sResult + .Name + vbCrLf
DataList.AddNew
DataList("SortName") = .Name
DataList.Update
End With
Next i
DataList.Sort = "SortName"
DataList.MoveFirst
Do Until DataList.EOF
sResult = sResult & DataList.Fields.Item("SortName") & vbCrLf
DataList.MoveNext
Loop
DataList.Close
Call SaveToFile(sResult, sStorePath + "Candidate.forms.txt")
' ==============================================================
' Ýêñïîðò Îò÷¸òîâ
DataList.Fields.Append "SortName", adVarChar, MaxCharacters
DataList.Open
sResult = " Íà äàòó " + Date$ + vbCrLf
sResult = sResult & " " & CurrentProject.AllReports.Count & " Reports in " & CurrentProject.FullName & vbCrLf
For i = 0 To CurrentProject.AllReports.Count - 1
With CurrentProject.AllReports(i)
' sResult = sResult + .Name + vbCrLf
DataList.AddNew
DataList("SortName") = .Name
DataList.Update
End With
Next i
DataList.Sort = "SortName"
DataList.MoveFirst
Do Until DataList.EOF
sResult = sResult & DataList.Fields.Item("SortName") & vbCrLf
DataList.MoveNext
Loop
DataList.Close
Call SaveToFile(sResult, sStorePath + "Candidate.reports.txt")
' ==============================================================
' Ýêñïîðò çàïðîñîâ
sStorePath = CodeProject.FullName
sStorePath = Left(sStorePath, InStrRev(sStorePath, ".") - 1) + "_Queries\"
If Not FSO.FolderExists(sStorePath) Then FSO.CreateFolder (sStorePath)
sResult = sResult & CurrentData.AllQueries.Count & " Queries in " & CurrentProject.FullName & vbCrLf
Set dbDATA = DBEngine.Workspaces(0).Databases(0)
sResult = "Íà äàòó " + Date$ + vbCrLf
With dbDATA
sResult = sResult & .QueryDefs.Count & " QueryDefs in " & .Name + vbCrLf
For Each qdfLoop In .QueryDefs
sResult = sResult + " " & qdfLoop.Name + vbCrLf
sModFName = ReplaceInvalidChars(qdfLoop.Name)
sR2 = qdfLoop.SQL
Call SaveToFile(sR2, sStorePath + sModFName + ".sql")
Next qdfLoop
End With
Call SaveToFile(sResult, sStorePath + "Candidate.queries.txt")
End Sub
Public Sub ReportToAnotherMDB()
Dim i As Integer
Dim sCurname As String
For i = 0 To CurrentProject.AllReports.Count - 1
With CurrentProject.AllReports(i)
sCurname = .Name
' DoCmd.RunCommand acCmdMakeMDEFile
' Call DoCmd.CopyObject("D:\Cam_3000\db1.mdb", sCurname, acReport, sCurname)
' Call DoCmd.DeleteObject(acReport, sCurname)
' sResult = sResult + .Name + vbCrLf
End With
Next i
End Sub
Public Sub SaveToFile(sString, sFileName As String)
Dim FSO, TextStream
On Error GoTo ErrorHandler
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TextStream = FSO.OpenTextFile(sFileName, ForWriting, True)
TextStream.Write (sString)
TextStream.Close
Exit_Sub:
Set FSO = Nothing
Exit Sub
ErrorHandler:
MsgBox Error$
Resume Exit_Sub
End Sub
Public Function ReplaceInvalidChars(sInput As String)
Dim sTemp
sTemp = Replace(sInput, "\", "_")
sTemp = Replace(sTemp, "/", "_")
sTemp = Replace(sTemp, """", "'")
ReplaceInvalidChars = Replace(sTemp, "|", "_")
End Function
Public Function GetProjectPath() As String
Dim sResult As String
sResult = CodeProject.FullName
GetProjectPath = Left(sResult, InStrRev(sResult, "\"))
End Function
|
