I've a VBA script as below.
Sub AutoOpen()
ActiveDocument.Variables("LastOpen").Value = Now()
End Sub
Sub AutoClose()
Dim objFSO, objFolder, objTextFile, objFile
Dim strDirectory, strFile, strText
strDirectory = "d:\work"
strFile = "\work.csv"
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check that the strDirectory folder exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
Debug.Print "Just created " & strDirectory
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
Debug.Print "Just created " & strDirectory & strFile
End If
Set objFile = Nothing
Set objFolder = Nothing
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, ForAppending, True)
'Build the string to write
strText = """" & ActiveDocument.FullName & """" & "," & ActiveDocument.Variables("LastOpen").Value & "," & Now()
' Writes strText every time you run this VBScript
objTextFile.WriteLine (strText)
objTextFile.Close
End Sub
here the macro is running fine, but the problem is when i open and close my word document, though there are no changes done, it asks me if i would like to save the changes like below.
please let me know how can i avoid this save dialogue box, if there are no changes made in document.
here if i open a blank document and close it, even then this is getting triggered.
As mentioned in comments, the creation of the variable in AutoOpen is causing this behavior.
Include a Save statement in AutoOpen:
Sub AutoOpen()
ActiveDocument.Variables("LastOpen").Value = Now()
ThisDocument.Save
End Sub
to avoid the Save prompt.
Related
Some of VBA Experts have helped me a lot and have fixed the code for me which moves one file one at a time but it first moves the oldest file in the folder. However here i have a complex situation which for now not resolving. i.e. I would like to add a timer of two hours i.e. the file should move after two hour.
e.g. If a file named "North_West data" whose modified time is 6:40 PM i would like the code to move it exactly after two hours. Similarly at the next run the next file which has to be moved has filed modified time e.g. 6:50 PM so the VBA code should actually move it exactly after two hours. this means each file should have automatic two hours delay timer in it, i hope i am able to clarify the query.
Function OldestFile(strFold As String) As String
Dim FSO As Object, Folder As Object, File As Object, oldF As String
Dim lastFile As Date: lastFile = Now
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strFold)
For Each File In Folder.Files
If File.DateLastModified < lastFile Then
lastFile = File.DateLastModified: oldF = File.Name
End If
Next
OldestFile = oldF
End Function
Sub MoveOldestFile()
Dim FromPath As String, ToPath As String, fileName As String
FromPath = "E:\Source\"
ToPath = "E:\Destination\"
fileName = OldestFile(FromPath)
If Dir(ToPath & fileName) = "" Then
Name FromPath & fileName As ToPath & fileName
Else
MsgBox "File """ & fileName & """ already moved..."
End If
End Sub
You can check the previously resolved query here
Previous query
Please, try the next way. Basically, it uses a VBScript able to catch file creation event, which sends the created file name and the moment of creation to a workbook which should be open all the time.
Create a VBScript and name it "FolderMonitor.vbs". To do that, please copy the next code in an empty Notepad window:
Dim oExcel, strWB, nameWB, wb
strWB = "C:\Teste VBA Excel\Folder monitor.xlsm" 'use here the path of the waiting workbook!
nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)
nameWB = Right(strWB, Len(nameWB))
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(nameWB)
if wb is nothing then wbscript.quit 'the necessary workbook is not open...
dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
strComputer = "."
'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.
'# So, you must use 4 backslashes (\\\\) as path separator!
strDirToMonitor = "C:\\\\test\\\\test" 'use here your path
'# Monitor Above every 10 secs...
strTime = "10"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
Do While True
Set objEventObject = colMonitoredEvents.NextEvent()
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
' Get the string to the left of the first \ and reverse it
MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))
MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
'send the information to the waiting workbook:
objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile,Now)
' some other events can be used starting from here...
End Select
Loop
And save it as stated above. But take care to not save it as "FolderMonitor.vbs.txt". In order to avoid that, when saving you should change 'Save as typefrom defaultText documents (.txt)toAll files (.*)`!
In order to make the following code working as it is, you should create a folder named "VBScript" in the folder where the workbook running the code exists and place the above VBScript inside!
Copy the next code in a standard module of a xlsm workbook. In order to be called by the above script, as it is, you should name it "Folder monitor.xlsm":
Option Explicit
Private Const ourScript As String = "FolderMonitor.vbs"
Private Const fromPath As String = "E:\Source\"
Sub startMonitoring()
Dim strVBSPath As String
strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
TerminateMonintoringScript 'to terminate monitoring script, if running..
Shell "cmd.exe /c """ & strVBSPath & """", 0
End Sub
Sub TerminateMonintoringScript()
Dim objWMIService As Object, colItems As Object, objItem As Object, Msg As String
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
For Each objItem In colItems
If objItem.Caption = "wscript.exe" Then
'// msg Contains the path of the exercutable script and the script name
On Error Resume Next
Msg = objItem.CommandLine 'for the case of null
On Error GoTo 0
'// If wbscript.exe runs the monitoring script:
If InStr(1, Msg, ourScript) > 0 Then
Debug.Print "Terminate Wscript process..."
objItem.Terminate 'terminate process
End If
End If
Next
Set objWMIService = Nothing: Set colItems = Nothing
End Sub
Sub GetMonitorInformation(arr As Variant)
'call DoSomething Sub after 2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
'for running after 2 hours you should change "00:01:00" in "02:00:00":
arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
Application.OnTime CDate(arr(1)) + TimeValue("00:01:00"), "'DoSomething """ & CStr(arr(0)) & """'"
Debug.Print "start " & Now 'just for testing (wait a minute...)
'finaly, this line should be commented.
End Sub
Sub DoSomething(strFileName As String)
Const toPath As String = "E:\Destination\"
If Dir(toPath & strFileName) = "" Then
Name fromPath & strFileName As toPath & strFileName
Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
Else
MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
End If
End Sub
a. You firstly should run "startMonitoring" Sub. It can be called from the Workbook_Open event.
b. Copy files in the monitored folder and check if they are copied as it should. Note that the code as it is move it after a minute. It is commented to exactly show what and how it can be changed...
I copied this code from a differen website to try and help me import multiple text files at once. I changed filepaths, text specs, and the table to what I need. Now every time I try to run this is locks up and doesn't respond.
Is there an issue with having too many text files or too much data? How come its causing my program to lock up?
Public Sub WorkedAlertsImport()
On Error GoTo bImportFiles_Click_Err
Dim objFS As Object, objFolder As Object
Dim objFiles As Object, objF1 As Object
Dim strFolderPath As String
strFolderPath = "C:\Import TXT files\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strFolderPath)
Set objFiles = objFolder.files
For Each objF1 In objFiles
If Right(objF1.Name, 3) = "txt" Then
DoCmd.TransferText acImportDelim, "TextImportSpecs", "tblImportedFiles", strFolderPath & objF1.Name, False
Name strFolderPath & objF1.Name As "C:\Import TXT files\" & objF1.Name 'Move the files to the archive folder
End If
Next
Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing
bImportFiles_Click_Exit:
Exit Sub
bImportFiles_Click_Err:
MsgBox Err.Number & " " & Err.Description
Resume bImportFiles_Click_Exit
End Sub
After a cursory review of your code, I see no reason why it would cause MS Access to lock up, which would typically be caused by code executing a loop which never met a terminating condition (however, a For Each loop is iterating over a fixed set of data and will therefore always terminate).
I would note that the following line is redundant:
Name strFolderPath & objF1.Name As "C:\Import TXT files\" & objF1.Name
Since earlier in the code you define strFolderPath as:
strFolderPath = "C:\Import TXT files\"
Hence, you are renaming the file to itself.
The code is also naïvely testing the last three characters of the filename, which may not necessarily yield an extension if you were to encounter a file without an extension.
The code could be written without using the FSO and without the if statement altogether, as VBA offers the Dir function as standard to iterate over files of a particular type in a directory, e.g.:
Sub test()
Dim strDir As String: strDir = "C:\Import TXT files"
Dim strTxt As String: strTxt = Dir(strDir & "\*.txt")
Do Until strTxt = vbNullString
DoCmd.TransferText acImportDelim, "TextImportSpecs", "tblImportedFiles", strDir & "\" & strTxt, False
strTxt = Dir
Loop
End Sub
I've been trying to find a script that saves attachments to a folder on our network from Outlook. I've finally got something working but it looks like it doesn't work on my 2nd system which happens to be Outlook 2010. I can't say for sure if it's because of this difference.
Code is:
Sub SaveAllAttachments(objItem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
strLocation = "C:\test\"
On Error GoTo ExitSub
If objItem.Class = olMail Then
Set objAttachments = objItem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strID = " from " & Format(Date, "mm-dd-yy") 'Append the Date
'strID = strID & " at " & Format(Time, "hh`mm AMPM") 'Append the Time
' These lines are going to retrieve the name of the
' attachment, attach the strID to it to insure it is
' a unique name, and then insure that the file
' extension is appended to the end of the file name.
strName = objAttachments.Item(dblLoop).Filename 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
' Tell the script where to save it and
' what to call it
strName1 = strLocation & "PDF\" & strName 'Put it all together
strName2 = strLocation & "JPG\" & strName 'Put it all together
' Save the attachment as a file.
objAttachments.Item(dblLoop).SaveAsFile strName1
objAttachments.Item(dblLoop).SaveAsFile strName2
Next dblLoop
objItem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub
It doesn't matter what Outlook version you are using at the moment. The code should work correcly.
Possible reasons why it doesn't work:
I'd suggest choosing another location for saving files. The C: drive requires admin privileges on latest OS.
The rule is not triggered.
An error in the script. Try to call the script manually from other VBA sub and see what happens under the hood. Do you get any errors in the code?
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
The following is the usual log function I utilize in alot of my vbscripts which I modify accordingly. I feel it writes too slow. I got 3 questions:
Any ideaas on how to optimize this so it writes faster?
Would it be faster to store all text in a string first then run the function OutputToLog or would it be faster to execute OutputToLog each time I needed to insert a string into the text file?
If drive space wasn't a factor, is it possible to run out of memory while writing to a text file during execution...causing the script to execute slower and slower?
Here is my vbscript function
Function OutputToLog (strToAdd)
Dim strDirectory,strFile,strText, objFile,objFolder,objTextFile,objFSO
strDirectory = "c:\log"
strFile = "\log-"& StampNow & ".bat"
'strText = "test"
strText = strToAdd
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check that the strDirectory folder exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
'WScript.Echo "Just created " & strDirectory
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
'Wscript.Echo "Just created " & strDirectory & strFile
End If
set objFile = nothing
set objFolder = nothing
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
Set objTextFile = objFSO.OpenTextFile _
(strDirectory & strFile, ForAppending, True)
' Writes strText every time you run this VBScript
objTextFile.WriteLine(strText)
objTextFile.Close
End Function
thanks in advance
I think you'd want to both create your FSO objects and open your log file outside the the OutputToLog function. It may not save much time, but why create objects, open and close files with every write?
Otherwise if you want to keep the functions as is, doing just one write should be quicker.
If you're doing a lot of small writes then refactoring the checks for FolderExists and FileExists out will help a bit. Maybe try to write to the file, trapping any errors, and check for FolderExists and FileExists in the error handler and create them if necessary?
It'll be quicker to output one large string rather than several small ones, but you have to balance that against the possibility of losing log entries if your program crashes.
Memory shouldn't be a problem unless you're writing a humungous string to the file, and probably not even then.
Because you're appending to the file, the longer the log file gets the longer the write will take, because (AFAIK) the entire file has to be rewritten each time. That's another reason for writing longer strings less frequently.
Could you use Windows' Event Log instead?
Do all your folder/file checking and creating once in a prep function, then you can just append to the log file safe in the knowledge that it'll be there? Also, you should be able to just create the fso object once.
Something like the following (untested code)
Dim loggerFSO
Function PrepLog
dim objFolder
' Create the File System Object
if loggerFSO is nothing then Set loggerFSO = CreateObject("Scripting.FileSystemObject")
' Check that the strDirectory folder exists
If loggerFSO.FolderExists(strDirectory) Then
Set objFolder = loggerFSO.GetFolder(strDirectory)
Else
Set objFolder = loggerFSO.CreateFolder(strDirectory)
'WScript.Echo "Just created " & strDirectory
End If
If loggerFSO.FileExists(strDirectory & strFile) Then
' do nothing
Else
loggerFSO.CreateTextFile(strDirectory & strFile)
'Wscript.Echo "Just created " & strDirectory & strFile
End If
End function
Function OutputToLog (strToAdd)
Dim strDirectory,strFile,strText, objTextFile
strDirectory = "c:\log"
strFile = "\log-"& StampNow & ".bat"
'strText = "test"
strText = strToAdd
' Create the File System Object
if loggerFSO is nothing then Set loggerFSO = CreateObject("Scripting.FileSystemObject")
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
Set objTextFile = loggerFSO.OpenTextFile _
(strDirectory & strFile, ForAppending, True)
' Writes strText every time you run this VBScript
objTextFile.WriteLine(strText)
objTextFile.Close
End Function
Don't close the file between calls, let the textstream-object take care of closing when it terminates.
Dim OutputToLogFileObject
Function OutputToLog (strToAdd)
Dim strDirectory,strFile,strText, objFile,objFolder,objTextFile,objFSO
If IsEmpty(OutputToLogFileObject) Then
strDirectory = "c:\log"
strFile = "\log-"& StampNow & ".bat"
'strText = "test"
strText = strToAdd
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check that the strDirectory folder exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
'WScript.Echo "Just created " & strDirectory
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
'Wscript.Echo "Just created " & strDirectory & strFile
End If
set objFile = nothing
set objFolder = nothing
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Const ForAppending = 8
Set OutputToLogFileObject = objFSO.OpenTextFile _
(strDirectory & strFile, ForAppending, True)
End If
OutputToLogFileObject.WriteLine strText
End Function