I have working code to:
Insert the Date, Company Name & Order Number into the proof at a specific location (data is pulled from the file location "C:\2020\My Company\Company Name\COM001 - 01\Layouts")
Determine the amount of pages in the document
Paste step 1 onto the other pages
Export the document as a .pdf
What I am trying to achieve, is before the .pdf is saved that the file is renamed (in this case COM001 - 01) adds a version indicator (" _v1") then saves the .cdr file and then runs the .pdf export function but does not overwrite the original.
I have been trying to adapt code I found on thespreadsheetguru.
The code adds the version indicator and exports the .pdf in the correct file location, but as soon as I open another file in a different location it will save it in the previous location instead.
Here is that piece of code: (I can upload the entire code if needed.)
Private Sub SaveNewVersion()
'PURPOSE: Save file, if already exists add a new version indicator to filename
Dim FolderPath, myPath, SaveName, SaveExt, VersionExt As String
Dim Saved As Boolean
Dim x As Long
Saved = False
x = 1
'Version Indicator (change to liking)
VersionExt = " _v"
'Pull info about file
On Error GoTo NotSavedYet
myPath = ActiveDocument.FileName
myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
On Error GoTo 0
'Determine Base File Name
If InStr(1, myFileName, VersionExt) > 1 Then
myArray = Split(myFileName, VersionExt)
SaveName = myArray(0)
Else
SaveName = myFileName
End If
'Need a new version made
Do While Saved = False
If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
ActiveDocument.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt
Saved = True
Else
x = x + 1
End If
Loop
Exit Sub
'Error Handler
NotSavedYet:
MsgBox "This file has not been initially saved. " & _
"Cannot save a new version!", vbCritical, "Not Saved To Computer"
End Sub
Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not
Dim TestStr As String
'Test File Path (ie "C:\Users\Chris\Desktop\Test\book1.xlsm")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
I have a feeling the code is messing up in the "pull info about file section".
You need to store the final path in a way that you can inspect it before you use it. Swap out this block of code here:
Dim newFileName as String
newFileName = FolderPath & SaveName & VersionExt & x & SaveExt
Debug.Print newFileName
If FileExist(newFileName) = False Then
ActiveDocument.SaveAs newFileName
Saved = True
Else
x = x + 1
End If
This will print the final filename to the Immediate Window before the save happens. If it is incorrect, change newFileName to be whatever you want.
Turns out it was a simple issue regarding the File path not returning any information..
changed out this code and now it works perfectly
On Error GoTo NotSavedYet
myFile = ActiveDocument.FileName
myPath = (ActiveDocument.FilePath)
myFileName = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myFile, Len(myFile) - InStrRev(myFile, "."))
Debug.Print FolderPath
On Error GoTo 0
Thanks #HackSlash for the tip, much appreciated
I have a Project that i have to finish soon but i get error when i try to Activate an Excel file with a variable inside of its Name.I get a runtime error 9 all the time even if I tried almost every Solutions that People suggested me.Thatswhy i send you the whole link, where it can be another Problem which causes this error.
Sub M01_Neue_Maßnahme()
'Variablen definieren
Dim Ord As String
Dim mNummer As String
Dim Jahr As String
Dim Welle As String
Dim Name As String
Dim mNummerGanz As String
Dim Exportart As Integer
Dim strOrdner As String
Dim meldung As String
Dim AlterLinkKurz As String
Dim verknuepfungsname_ist As String
Dim verknuepfungsname_soll As String
Dim verknuepfungsname_soll_teil As String
Exportart = Worksheets("Vorgaben").Range("C5").Value
Ord = Worksheets("Vorgaben").Range("C4").Value
User has been asked to fill out two Input Box, which is for documenting the Excel file while saving it.
mNummer = InputBox("Bitte Maßnahmennummer eingeben")
Welle = InputBox("Bitte Welle auswählen", , "0" & Worksheets("Vorgaben").Range("B15").Value)
mNummerGanz = mNummer & "" & "" & Welle
Dim a As String
Dim b As String
AlterLinkKurz = Worksheets("Eingabefeld").Range("AO47").Value
aLinks = ActiveWorkbook.LinkSources()
If Not IsEmpty(aLinks) Then
For i = 1 To UBound(aLinks)
verknuepfungsname_ist = Mid(aLinks(i), InStrRev(aLinks(i), "\") + 1, Len(aLinks(i)) - InStrRev(aLinks(i), "\"))
verknuepfungsname_soll_teil = Mid(AlterLinkKurz, InStrRev(AlterLinkKurz, "\") + 1, Len(AlterLinkKurz) - InStrRev(AlterLinkKurz, "\"))
If verknuepfungsname_ist = verknuepfungsname_soll_teil Then
'Durch kopieren der xlsx modifizierte Links werden zurückgesetzt
If aLinks(i) <> AlterLinkKurz Then
AlterLinkKurz = aLinks(i)
End If
End If
Next i
End If
NeuerLink = Worksheets("Vorgaben").Range("C10").Value
For Each link In ActiveWorkbook.LinkSources(xlExcelLinks)
If InStr(link, AlterLinkKurz) > 0 Then
Application.DisplayAlerts = False
ActiveWorkbook.ChangeLink link, _
NeuerLink, xlLinkTypeExcelLinks
End If
Next
Saving the file with the a variable Name under "Dateiname"
If Exportart = 1 Then
If Dir(Ord, vbDirectory) <> "" Then
Else
MsgBox ("Standardpfad nicht vorhanden." & vbCr & "Datei wird im folgenden Verzeichnis abgelegt:" & vbCr & vbCr & Ord)
MkDir Ord
End If
Dateiname = Ord & mNummerGanz & "_" & Name & ".xlsm"
ThisWorkbook.SaveAs Filename:=Dateiname
Now i open a file called 1.xlsm, i want to copy a Content from this file and then activate the variable Named file and paste it on that file. But i get an error.
'Opening 1.xlsm
ChDir _
"Z:\1000_Entwicklung\05_PROJECT\0558000_CFT\055800L_CFT_Projektleitung\99_Arbeitsordner PL\Tanverdi\SummaryPPT"
Workbooks.Open Filename:= _
"Z:\1000_Entwicklung\05_PROJECT\0558000_CFT\055800L_CFT_Projektleitung\99_Arbeitsordner PL\Tanverdi\SummaryPPT\1.xlsm"
Range("G5:P41").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
I wanted to paste the content in the file which i have saved under variable Dateiname, i get runtime error 9.
Windows(Dateiname).Activate
I am sorry this could be easy to ask but i am new at VBA and Need so much your help.
I have multiple .csv files that I need to find the length of in my directory. (The number of rows that have data in them.) I'm running the following code from a .xlsx file in the same directory. (I intend to copy data from the .csv files to the .xlsx file eventually.)
i = 1
FilePath = Application.ActiveWorkbook.Path & "\"
file = Dir(FilePath & "*.csv")
Do While Len(file) > 0
Open FilePath & file For Input As #1
length(i) = Cells(Rows.Count, 1).End(xlUp).Row
i = i + 1
Close #1
file = Dir
Loop
All the values of the length array end up being 1, even though the .csv files are probably 15-20 rows long.
You're not actually opening the file in Excel so you can't count how many cells there are. Try reading how many lines instead:
Open FilePath & file For Input As #1
While Not EOF(1): Line Input #1, trashLine: Wend
i = i + 1
Close #1
Alternatively, open the file in Excel - test - then close afterwards:
Set tempWB = Workbooks.Open(FilePath & file)
i = i + tempWB.Sheets(1).Cells(tempWB.Sheets(1).Rows.Count, 1).End(xlUp).Row
tempWB.Close False
Or an even quicker way is to use Windows Script:
Dim i As Long
For Each varFile In _
Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c find /v /c """" """ _
& ThisWorkbook.Path & "\*.csv""").StdOut.ReadAll, vbCrLf), ":")
i = i + CLng(Split(varFile, ":")(2))
Next
Debug.Print i
That way, if you've got 10 files the code is only working with 10 strings rather than opening/closing a file or reading thousands of lines...
As #SOofWXLS stated, your code is not opening the files in Excel, you are opening them for direct i/o.
Here is a complete code sample that will fill your array with the file lengths as you were trying to do.
Dim fPath As String
Dim fName As String
Dim hFile As Long
Dim i As Long
Dim NumLines As Long
Dim length() As Long
Dim strLine As String
ReDim length(1 To 1)
fPath = Application.ActiveWorkbook.Path & "\"
fName = Dir(fPath & "*.csv")
Do While Len(fName) > 0
i = i + 1
NumLines = 0
ReDim Preserve length(1 To i)
hFile = FreeFile
Open fPath & fName For Input As hFile
Do While Not EOF(hFile)
Line Input #hFile, strLine
NumLines = NumLines + 1
Loop
Close hFile
length(i) = NumLines
fName = Dir
Loop
This will also dynamically expand your array to accommodate as many files as are found.
I have this code which finds file names(along with file paths) based on search string.This code works fine in finding single files. I would like this macro to find multiple files and get their names displayed separated using a comma.
Function FindFiles(path As String, SearchStr As String)
Dim FileName As String ' Walking filename variable.
Dim DirName As String ' SubDirectory Name.
Dim dirNames() As String ' Buffer for directory name entries.
Dim nDir As Integer ' Number of directories in this path.
Dim i As Integer ' For-loop counter.
Dim Name As String
Dim Annex As String
On Error GoTo sysFileERR
If Right(path, 1) <> "\" Then path = path & "\"
' Search for subdirectories.
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden Or vbArchive Or vbReadOnly _
Or vbSystem) ' Even if hidden, and so on.
Do While Len(DirName) > 0
' Ignore the current and encompassing directories.
If (DirName <> ".") And (DirName <> "..") Then
' Check for directory with bitwise comparison.
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
'List2.AddItem path & DirName ' Uncomment to list
End If ' directories.
sysFileERRCont:
End If
DirName = Dir() ' Get next subdirectory.
Loop
' Search through this directory and sum file sizes.
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
Or vbReadOnly Or vbArchive)
'Sheet1.Range("C1").Value2 = path & "\" & FileName
While Len(FileName) <> 0
FindFiles = path & "\" & FileName
FileCount = FileCount + 1
' Load List box
' Sheet1.Range("A1").Value2 = path & FileName & vbTab & _
FileDateTime(path & FileName) ' Include Modified Date
FileName = Dir() ' Get next file.
Wend
' If there are sub-directories..
If nDir > 0 Then
' Recursively walk into them
For i = 0 To nDir - 1
FindFiles = path & "\" & FileName
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont ' Known issue with pagefile.sys
Else
MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
"Unexpected Error"
Resume AbortFunction
End If
End Function
Sub Find_Files()
Dim SearchPath As String, FindStr As String, SearchPath1 As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Dim Filenames As String, Filenames1 As String
Dim r As Range
'Screen.MousePointer = vbHourglass
'List2.Clear
For Each cell In Range("SS")
SearchPath = Sheet3.Range("B2").Value2
SearchPath1 = Sheet3.Range("B3").Value2
FindStr = Cells(cell.Row, "H").Value
Filenames = FindFiles(SearchPath, FindStr)
Filenames1 = FindFiles(SearchPath1, FindStr)
'Sheet1.Range("B1").Value2 = NumFiles & " Files found in " & NumDirs + 1 & _
" Directories"
Cells(cell.Row, "F").Value = Filenames
Cells(cell.Row, "G").Value = Filenames1
'Format(FileSize, "#,###,###,##0") & " Bytes"
'Screen.MousePointer = vbDefault
Next cell
End Sub
Any thoughts will be highly appreciated.
I realize this question is very old, but it is unanswered. Here is a quick method for finding multiple files and their paths. VBA's DIR function isn't really very handy, but CMD's DIR function is well optimized and has a plethora of command line switches to make it return only files (or even just folders) that match your criteria. The trick is to call DIRfrom a WScript shell so that the output can be parsed by VBA.
For example, this snippet of code will find every file on your system that starts with config.
Dim oShell As Object 'New WshShell if you want early binding
Dim cmd As Object 'WshExec if you want early binding
Dim x As Integer
Const WshRunning = 0
Set oShell = CreateObject("Wscript.Shell")
Set cmd = oShell.Exec("cmd /c ""Dir c:\config* /a:-d /b /d /s""")
Do While cmd.Status = WshRunning
DoEvents
Loop
Debug.Print cmd.StdOut.ReadAll
Set oShell = Nothing
Set cmd = Nothing
I found some code on an ancient message board that nicely exports all of the VBA code from classes, modules and forms (see below):
Option Explicit
Option Compare Database
Function SaveToFile() 'Save the code for all modules to files in currentDatabaseDir\Code
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
However, this code does not solve my problem since I have 110 ms-access *.mdb's that I need to export the vba from into text files suitable for grepping.
The paths to the 110 files I'm interested in are already stored in a table, and my code already gained this information recursively (along with some other filtering)...so the recursive part is done.
Most of these files are opened by a single access user security file, an .mdw and I have tried several methods of opening them. ADO and ADOX worked great when I was searching for linked tables in these directories...but the code above involves being inside the database you are exporting the data from, and I want to be able to do this from a separate database that opens all of the mdbs and performs the export on each of them.
One of my attempts at this involved using the PrivDBEngine class to connect to the databases externally, but it doesn't allow me to access the Application object which is what the export code above requires.
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:\Tickets\CSN1006218\vbacode\" & 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
Is there anyway to access the application object from a PrivDBEngine? I have alot of modules that need grepping.
You can also try this code. It will preserve the items' filetypes (.bas, .cls, .frm)
Remember to refer to / Check the Microsoft Visual Basic For Applications Extensibility Library in
VBE > Tools > References
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
You can use the Access.Application object.
Also, in order to avoid multiple confirmation dialogs when opening the databases, just change the security level in Tools / Macros / Security.
And to open multiple databases with user/password you can join the workgroup (Tools / Security / Workgroup administrator) and log in with the desired user/password (from the database with the SaveToFile function), then run the code. Remember, later on, to join the default workgroup (you can try to join an inexistent workgroup and access will revert to the default).
Option Explicit
Option Compare Database
'Save the code for all modules to files in currentDatabaseDir\Code
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:\Access\myDatabase.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
I have added code for the Reports modules. When I get some time I'll try to refactor the code.
I find this a great contribution. Thanks for sharing.
Regards
================= EDIT ==================
After a while I found the way to export the whole database (tables and queries included) and have been using it for version control in Git.
Of course, if you have really big tables what you really want is a backup. This I use with the tables in its initial state, many of them empty, for development purposes only.
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
'
EDIT2
When saving queries, they often get changed in trivial aspects which I don't want to get commited to the git repository. I changed the code so it just exports the SQL code in the query.
For Each oQuery In CurrentDb.QueryDefs
strName = oQuery.Name
If Left(strName, 1) <> "~" Then
strFileName = strPath & "\" & strName & EXT_QUERY
saveQueryAsText oQuery, strFileName
End If
Next
'
' Save just the SQL code in the query
'
Private Sub saveQueryAsText(ByVal oQuery As QueryDef, ByVal strFileName As String)
Dim intFile As Integer
intFile = FreeFile
Open strFileName For Output As intFile
Print #intFile, oQuery.sql
Close intFile
End Sub
And to import and recreate the database I use another module, mDBImport. In the repository, the modules are contained in the 'modules' subfolder:
Private Const repoPath As String = "C:\your\repository\path\here"
Public Sub loadFromText(Optional ByVal strPath As String = REPOPATH)
dim FSO as Object
Set oFolder = FSO.GetFolder(strPath)
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each oFile In oFolder.files
Select Case FSO.GetExtensionName(oFile.Path)
Case "tbl"
Application.ImportXML oFile.Path, acStructureAndData
Case "qry"
intFile = FreeFile
Open oFile.Path For Input As #intFile
strSQL = Input$(LOF(intFile), intFile)
Close intFile
CurrentDb.CreateQueryDef Replace(oFile.Name, ".qry", ""), strSQL
Case "frm"
Application.loadFromText acForm, Replace(oFile.Name, ".frm", ""), oFile.Path
End Select
Next oFile
' load modules and class modules
strPath = FSO.BuildPath(strPath, "modules")
If Not FSO.FolderExists(strPath) Then Err.Raise vbObjectError + 4, , "Modules folder doesn't exist!"
Set oFolder = FSO.GetFolder(strPath)
With Application.VBE.ActiveVBProject.VBComponents
For Each oFile In oFolder.files
Select Case FSO.GetExtensionName(oFile.Path)
Case "cls", "bas"
If oFile.Name <> "mDBImport.bas" Then .Import oFile.Path
End Select
Next oFile
End With
MsgBox "The database objects where correctly loaded.", vbOKOnly, "LoadFromText"
Exit Sub
errHandler:
MsgBox Err.Description, vbCritical + vbOKOnly
End Sub
Like for MS Excel, you can also use a loop over the Application.VBE.VBProjects(1).VBComponents and use the Export method to export your modules/classes/forms:
Const VB_MODULE = 1
Const VB_CLASS = 2
Const VB_FORM = 100
Const EXT_MODULE = ".bas"
Const EXT_CLASS = ".cls"
Const EXT_FORM = ".frm"
Const CODE_FLD = "Code"
Sub ExportAllCode()
Dim fileName As String
Dim exportPath As String
Dim ext As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
' Set export path and ensure its existence
exportPath = CurrentProject.path & "\" & CODE_FLD
If Not FSO.FolderExists(exportPath) Then
MkDir exportPath
End If
' The loop over all modules/classes/forms
For Each c In Application.VBE.VBProjects(1).VBComponents
' Get the filename extension from type
ext = vbExtFromType(c.Type)
If ext <> "" Then
fileName = c.name & ext
debugPrint "Exporting " & c.name & " to file " & fileName
' THE export
c.Export exportPath & "\" & fileName
Else
debugPrint "Unknown VBComponent type: " & c.Type
End If
Next c
End Sub
' Helper function that translates VBComponent types into file extensions
' Returns an empty string for unknown types
Function vbExtFromType(ByVal ctype As Integer) As String
Select Case ctype
Case VB_MODULE
vbExtFromType = EXT_MODULE
Case VB_CLASS
vbExtFromType = EXT_CLASS
Case VB_FORM
vbExtFromType = EXT_FORM
End Select
End Function
Only takes a fraction of a second to execute.
Cheers
Lovely answer Clon.
Just a slight variation if you are trying to open MDBs that has a startup form and/or a AutoExec macro and above doesn't always seem to work reliably.
Looking at this answer on another website: By pass startup form / macros and scrolling almost to the end of the discussion is some code which temporarily gets rid of the startup form settings and extracts the AutoExec macro to your database before writing over it with an TempAutoExec macro (which does nothing), does some work (between lines 'Read command bars and app.CloseCurrentDatabase) and then fixes everything back again.
IDK why no one has suggested this before, but here is a small piece of code I use for this. Pretty simple and straightforward
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
another way is keep most used code in one external master.mdb
and join it to any count of *.mdbs trough Modules->Tools->References->Browse->...\master.mdb
the only problem in old 97 Access you can Debug, Edit and Save directly in destination.mdb,
but in all newer, since MA 2000, 'Save' option is gone and any warnings on close unsaved code