Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Option Explicit
- Option Compare Database
- Function SaveToFile() 'Save the code for all modules to files in currentDatabaseDirCode
- Dim Name As String
- Dim WasOpen As Boolean
- Dim Last As Integer
- Dim I As Integer
- Dim TopDir As String, Path As String, FileName As String
- Dim F As Long 'File for saving code
- Dim LineCount As Long 'Line count of current module
- I = InStrRev(CurrentDb.Name, "")
- TopDir = VBA.Left(CurrentDb.Name, I - 1)
- Path = TopDir & "" & "Code" 'Path where the files will be written
- If (Dir(Path, vbDirectory) = "") Then
- MkDir Path 'Ensure this exists
- End If
- '--- SAVE THE STANDARD MODULES CODE ---
- Last = Application.CurrentProject.AllModules.Count - 1
- For I = 0 To Last
- Name = CurrentProject.AllModules(I).Name
- WasOpen = True 'Assume already open
- If Not CurrentProject.AllModules(I).IsLoaded Then
- WasOpen = False 'Not currently open
- DoCmd.OpenModule Name 'So open it
- End If
- LineCount = Access.Modules(Name).CountOfLines
- FileName = Path & "" & Name & ".vba"
- If (Dir(FileName) <> "") Then
- Kill FileName 'Delete previous version
- End If
- 'Save current version
- F = FreeFile
- Open FileName For Output Access Write As #F
- Print #F, Access.Modules(Name).Lines(1, LineCount)
- Close #F
- If Not WasOpen Then
- DoCmd.Close acModule, Name 'It wasn't open, so close it again
- End If
- Next
- '--- SAVE FORMS MODULES CODE ---
- Last = Application.CurrentProject.AllForms.Count - 1
- For I = 0 To Last
- Name = CurrentProject.AllForms(I).Name
- WasOpen = True
- If Not CurrentProject.AllForms(I).IsLoaded Then
- WasOpen = False
- DoCmd.OpenForm Name, acDesign
- End If
- LineCount = Access.Forms(Name).Module.CountOfLines
- FileName = Path & "" & Name & ".vba"
- If (Dir(FileName) <> "") Then
- Kill FileName
- End If
- F = FreeFile
- Open FileName For Output Access Write As #F
- Print #F, Access.Forms(Name).Module.Lines(1, LineCount)
- Close #F
- If Not WasOpen Then
- DoCmd.Close acForm, Name
- End If
- Next
- MsgBox "Created source files in " & Path
- End Function
- Private Sub exportToFile(db_path As String, db_id As String, loginInfo As AuthInfoz, errFile As Variant)
- Dim pdbeNew As PrivDBEngine
- Dim db As DAO.Database
- Dim ws As DAO.Workspace
- Dim rst As DAO.Recordset
- Dim cn As ADODB.Connection ' ADODB.Connection
- Dim rs As ADODB.Recordset ' ADODB.Recordset
- Dim strConnect As String
- Dim blnReturn As Boolean
- Dim Doc As Document
- Dim mdl As Module
- Dim lngCount As Long
- Dim strForm As String
- Dim strOneLine As String
- Dim sPtr As Integer
- Set fso = CreateObject("Scripting.FileSystemObject")
- Set exportFile = fso.CreateTextFile("E:TicketsCSN1006218vbacode" & db_id & ".txt", ForAppending)
- ' Export stuff...
- On Error GoTo errorOut
- Set pdbeNew = New PrivDBEngine
- With pdbeNew
- .SystemDB = loginInfo.workgroup
- .DefaultUser = loginInfo.username
- .DefaultPassword = loginInfo.password
- End With
- Set ws = pdbeNew.Workspaces(0)
- Set db = ws.OpenDatabase(db_path)
- For Each Doc In db.Containers("Modules").Documents
- DoCmd.OpenModule Doc.Name
- Set mdl = Modules(Doc.Name)
- exportFile.WriteLine ("---------------------")
- exportFile.WriteLine ("Module Name: " & Doc.Name)
- exportFile.WriteLine ("Module Type: " & mdl.Type)
- exportFile.WriteLine ("---------------------")
- lngCount = lngCount + mdl.CountOfLines
- 'For i = 1 To lngCount
- ' strOneLine = mdl.Lines(i, 1)
- ' exportFile.WriteLine (strOneLine)
- 'Next i
- Set mdl = Nothing
- DoCmd.Close acModule, Doc.Name
- Next Doc
- Close_n_exit:
- If Not (db Is Nothing) Then
- Call wk.Close
- Set wk = Nothing
- Call db.Close
- End If
- Call exportFile.Close
- Set exportFile = Nothing
- Set fso = Nothing
- Exit Sub
- errorOut:
- Debug.Print "----------------"
- Debug.Print "BEGIN: Err"
- If err.Number <> 0 Then
- Msg = "Error # " & Str(err.Number) & " was generated by " _
- & err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & err.Description
- 'MsgBox Msg, , "Error", err.HelpFile, err.HelpContext
- Debug.Print Msg
- End If
- Resume Close_n_exit
- End Sub
- Public Sub ExportAllCode()
- Dim c As VBComponent
- Dim Sfx As String
- For Each c In Application.VBE.VBProjects(1).VBComponents
- Select Case c.Type
- Case vbext_ct_ClassModule, vbext_ct_Document
- Sfx = ".cls"
- Case vbext_ct_MSForm
- Sfx = ".frm"
- Case vbext_ct_StdModule
- Sfx = ".bas"
- Case Else
- Sfx = ""
- End Select
- If Sfx <> "" Then
- c.Export _
- Filename:=CurrentProject.Path & "" & _
- c.Name & Sfx
- End If
- Next c
- End Sub
- Option Explicit
- Option Compare Database
- 'Save the code for all modules to files in currentDatabaseDirCode
- Public Function SaveToFile()
- On Error GoTo SaveToFile_Err
- Dim Name As String
- Dim WasOpen As Boolean
- Dim Last As Integer
- Dim i As Integer
- Dim TopDir As String, Path As String, FileName As String
- Dim F As Long 'File for saving code
- Dim LineCount As Long 'Line count of current module
- Dim oApp As New Access.Application
- ' Open remote database
- oApp.OpenCurrentDatabase ("D:AccessmyDatabase.mdb"), False
- i = InStrRev(oApp.CurrentDb.Name, "")
- TopDir = VBA.Left(oApp.CurrentDb.Name, i - 1)
- Path = TopDir & "" & "Code" 'Path where the files will be written
- If (Dir(Path, vbDirectory) = "") Then
- MkDir Path 'Ensure this exists
- End If
- '--- SAVE THE STANDARD MODULES CODE ---
- Last = oApp.CurrentProject.AllModules.Count - 1
- For i = 0 To Last
- Name = oApp.CurrentProject.AllModules(i).Name
- WasOpen = True 'Assume already open
- If Not oApp.CurrentProject.AllModules(i).IsLoaded Then
- WasOpen = False 'Not currently open
- oApp.DoCmd.OpenModule Name 'So open it
- End If
- LineCount = oApp.Modules(Name).CountOfLines
- FileName = Path & "" & Name & ".vba"
- If (Dir(FileName) <> "") Then
- Kill FileName 'Delete previous version
- End If
- 'Save current version
- F = FreeFile
- Open FileName For Output Access Write As #F
- Print #F, oApp.Modules(Name).Lines(1, LineCount)
- Close #F
- If Not WasOpen Then
- oApp.DoCmd.Close acModule, Name 'It wasn't open, so close it again
- End If
- Next
- '--- SAVE FORMS MODULES CODE ---
- Last = oApp.CurrentProject.AllForms.Count - 1
- For i = 0 To Last
- Name = oApp.CurrentProject.AllForms(i).Name
- WasOpen = True
- If Not oApp.CurrentProject.AllForms(i).IsLoaded Then
- WasOpen = False
- oApp.DoCmd.OpenForm Name, acDesign
- End If
- LineCount = oApp.Forms(Name).Module.CountOfLines
- FileName = Path & "" & Name & ".vba"
- If (Dir(FileName) <> "") Then
- Kill FileName
- End If
- F = FreeFile
- Open FileName For Output Access Write As #F
- Print #F, oApp.Forms(Name).Module.Lines(1, LineCount)
- Close #F
- If Not WasOpen Then
- oApp.DoCmd.Close acForm, Name
- End If
- Next
- '--- SAVE REPORTS MODULES CODE ---
- Last = oApp.CurrentProject.AllReports.Count - 1
- For i = 0 To Last
- Name = oApp.CurrentProject.AllReports(i).Name
- WasOpen = True
- If Not oApp.CurrentProject.AllReports(i).IsLoaded Then
- WasOpen = False
- oApp.DoCmd.OpenReport Name, acDesign
- End If
- LineCount = oApp.Reports(Name).Module.CountOfLines
- FileName = Path & "" & Name & ".vba"
- If (Dir(FileName) <> "") Then
- Kill FileName
- End If
- F = FreeFile
- Open FileName For Output Access Write As #F
- Print #F, oApp.Reports(Name).Module.Lines(1, LineCount)
- Close #F
- If Not WasOpen Then
- oApp.DoCmd.Close acReport, Name
- End If
- Next
- MsgBox "Created source files in " & Path
- ' Reset the security level
- Application.AutomationSecurity = msoAutomationSecurityByUI
- SaveToFile_Exit:
- If Not oApp.CurrentDb Is Nothing Then oApp.CloseCurrentDatabase
- If Not oApp Is Nothing Then Set oApp = Nothing
- Exit function
- SaveToFile_Err:
- MsgBox ("Error " & Err.Number & vbCrLf & Err.Description)
- Resume SaveToFile_Exit
- End Function
- Option Compare Database
- Option Explicit
- Private Const VB_MODULE As Integer = 1
- Private Const VB_CLASS As Integer = 2
- Private Const VB_FORM As Integer = 100
- Private Const EXT_TABLE As String = ".tbl"
- Private Const EXT_QUERY As String = ".qry"
- Private Const EXT_MODULE As String = ".bas"
- Private Const EXT_CLASS As String = ".cls"
- Private Const EXT_FORM As String = ".frm"
- Private Const CODE_FLD As String = "code"
- Private Const mblnSave As Boolean = True ' False: just generate the script
- '
- '
- Public Sub saveAllAsText()
- Dim oTable As TableDef
- Dim oQuery As QueryDef
- Dim oCont As Container
- Dim oForm As Document
- Dim oModule As Object
- Dim FSO As Object
- Dim strPath As String
- Dim strName As String
- Dim strFileName As String
- '**
- On Error GoTo errHandler
- strPath = CurrentProject.path
- Set FSO = CreateObject("Scripting.FileSystemObject")
- strPath = addFolder(FSO, strPath, Application.CurrentProject.name & "_" & CODE_FLD)
- strPath = addFolder(FSO, strPath, Format(Date, "yyyy.mm.dd"))
- For Each oTable In CurrentDb.TableDefs
- strName = oTable.name
- If left(strName, 4) <> "MSys" Then
- strFileName = strPath & "" & strName & EXT_TABLE
- If mblnSave Then Application.ExportXML acExportTable, strName, strFileName, strFileName & ".XSD", strFileName & ".XSL", , acUTF8, acEmbedSchema + acExportAllTableAndFieldProperties
- Debug.Print "Application.ImportXML """ & strFileName & """, acStructureAndData"
- End If
- Next
- For Each oQuery In CurrentDb.QueryDefs
- strName = oQuery.name
- If left(strName, 1) <> "~" Then
- strFileName = strPath & "" & strName & EXT_QUERY
- If mblnSave Then Application.SaveAsText acQuery, strName, strFileName
- Debug.Print "Application.LoadFromText acQuery, """ & strName & """, """ & strFileName & """"
- End If
- Next
- Set oCont = CurrentDb.Containers("Forms")
- For Each oForm In oCont.Documents
- strName = oForm.name
- strFileName = strPath & "" & strName & EXT_FORM
- If mblnSave Then Application.SaveAsText acForm, strName, strFileName
- Debug.Print "Application.LoadFromText acForm, """ & strName & """, """ & strFileName & """"
- Next
- strPath = addFolder(FSO, strPath, "modules")
- For Each oModule In Application.VBE.ActiveVBProject.VBComponents
- strName = oModule.name
- strFileName = strPath & "" & strName
- Select Case oModule.Type
- Case VB_MODULE
- If mblnSave Then oModule.Export strFileName & EXT_MODULE
- Debug.Print "Application.VBE.ActiveVBProject.VBComponents.Import """ & strFileName & EXT_MODULE; """"
- Case VB_CLASS
- If mblnSave Then oModule.Export strFileName & EXT_CLASS
- Debug.Print "Application.VBE.ActiveVBProject.VBComponents.Import """ & strFileName & EXT_CLASS; """"
- Case VB_FORM
- ' Do not export form modules (already exported the complete forms)
- Case Else
- Debug.Print "Unknown module type: " & oModule.Type, oModule.name
- End Select
- Next
- If mblnSave Then MsgBox "Files saved in " & strPath, vbOKOnly, "Export Complete"
- Exit Sub
- errHandler:
- MsgBox "Error " & Err.Number & ": " & Err.Description & vbCrLf
- Stop: Resume
- End Sub
- '
- '
- ' Create a folder when necessary. Append the folder name to the given path.
- '
- Private Function addFolder(ByRef FSO As Object, ByVal strPath As String, ByVal strAdd As String) As String
- addFolder = strPath & "" & strAdd
- If Not FSO.FolderExists(addFolder) Then MkDir addFolder
- End Function
- '
- Public Sub VBAExportModule()
- On Error GoTo Errg
- Dim rs As DAO.Recordset
- Set rs = CurrentDb.OpenRecordset("SELECT MSysObjects.Name FROM MSysObjects WHERE Type=-32761", dbOpenDynaset, dbSeeChanges)
- Do Until rs.EOF
- Application.SaveAsText acModule, rs("Name"), "C:" & rs("Name") & ".txt"
- rs.MoveNext
- Loop
- Cleanup:
- If Not rs Is Nothing Then rs.Close
- Set rs = Nothing
- Exit Sub
- Errg:
- GoTo Cleanup
- End Sub
Add Comment
Please, Sign In to add comment