Related
I got problem with one of my subroutines, which job is to convert any passed ListObject (ussually generated by powerquery) into multiple MySQL queries, then send them to database. Queries and progress are shown on userform, that refresh with every query. My problem is that for some reason with some large tables, code starts out very quickly, but at some point it instantly slows down to fraction of speed it started and excel ram usage is increasing by +-1MB/s while running, and after code finish, it stays there.
With smaller tables (low column count, or small values in cells) it can process tens of thousands rows very fast without slowing, but problem comes with some large tables (either higher column count, or big values in cells, for ex. long strings etc...) after like 3k rows.
This sub is responsible for looping thru table, and building insert queries, then every few rows (depending on query length) calls function, that can send any query into selected DB. The problem is in "For i" loop, but i including whole code here.
Public Sub UploadniPayload(DBtabulka As String, Zdroj As ListObject, Optional Databaze As String = "tesu")
If ErrorMode = False Then On Error Resume Next
Dim Prikaz As String, Radek As String, Payload As String, i As Long, x As Long, PocetRadku As Long, PocetSloupcu As Long, DBsloupce As Long
Call VyplnNetInfo(DBIP)
AutoUploader.loading_sql.Value = 0
PocetRadku = Zdroj.DataBodyRange.Rows.Count
PocetSloupcu = Zdroj.DataBodyRange.Columns.Count
DBsloupce = DBPocetSloupcu(DBtabulka, Databaze)
If JeTabulkaPrazdna(Zdroj) = False Then
If (Zdroj.DataBodyRange.Columns.Count + 1) = DBsloupce Then
'PROBLEM APPEARING IN THIS LOOP
For i = 1 To PocetRadku
For x = 1 To PocetSloupcu
If x <= 0 Then Exit For
If x = 1 Then
Payload = "'','" & Zdroj.DataBodyRange(i, x).Text & "'"
Else
Payload = Payload & ",'" & Zdroj.DataBodyRange(i, x).Text & "'"
End If
Next x
Radek = "(" & Payload & ")"
If Prikaz <> vbNullString Then Prikaz = Prikaz & ", " & Radek Else Prikaz = Radek
If i = PocetRadku Or Len(Prikaz) > 2500 Then
AutoUploader.loading_sql.Value = i / PocetRadku
AutoUploader.txtStatus.Caption = "Zpracovávám " & i & "/" & PocetRadku & " řádků"
Prikaz = "INSERT INTO `" & Databaze & "`.`" & DBtabulka & "` VALUES " & Prikaz
Call PrikazSQL(Prikaz, Databaze)
Prikaz = vbNullString
Payload = vbNullString
End If
Next i
Else
Call Zaloguj("System", "Error - počet sloupců v " & Zdroj.Name & " (" & PocetSloupcu & "+1 ID) nesouhlasí s počtem sloupců v " & DBtabulka & "(" & DBsloupce & ")", False)
End If
Else
Call Zaloguj("System", "Error - pokus o upload prázdné tabulky (" & Zdroj.Name & ") do DB (" & DBtabulka & ")", False)
End If
If AutoUploader.chb_Uklizecka.Value = True Then Call VycistiTabulku(Zdroj)
End Sub
And this is my function responsible for sending queries into database.
Sometimes i use it for pulling single value from database, so it acts as string, but when i need only insert, i just using Call. DBIP, DBUser and DBPass are global variables.
Public Function PrikazSQL(ByRef Prikaz As String, Optional Databaze As String = "tesu") As String
On Error GoTo ErrHandler
AutoUploader.IconDirectSQL.BackColor = vbGreen
AutoUploader.txtKUK.Value = Prikaz
'If ErrorMode = True Then Call Zasifruj
DoEvents
Dim Pripojeni As ADODB.Connection, RS As ADODB.Recordset
Set Pripojeni = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.RecordSet")
Pripojeni.Open "" & _
"DRIVER={MySQL ODBC 8.0 UNICODE Driver}" & _
";SERVER=" & DBIP & _
";DATABASE=" & Databaze & _
";USER=" & DBUser & _
";PASSWORD=" & DBPass & _
";Option=3"
With RS
.CursorLocation = adUseClient
.LockType = adLockBatchOptimistic
.Open Prikaz, Pripojeni
.ActiveConnection = Nothing
End With
Pripojeni.Close
Set Pripojeni = Nothing
If RS.Fields.Count > 0 Then PrikazSQL = RS(0)
Set RS = Nothing
AutoUploader.IconDirectSQL.BackColor = vbWhite
DoEvents
Exit Function
ErrHandler:
RS.ActiveConnection = Nothing
If Not Pripojeni Is Nothing Then
Pripojeni.Close
Set Pripojeni = Nothing
End If
If RS.Fields.Count > 0 Then PrikazSQL = RS(0)
Set RS = Nothing
AutoUploader.IconDirectSQL.BackColor = vbWhite
DoEvents
Call Debuger("ERROR:" & vbCrLf & Err.Description & vbCrLf & vbCrLf & "QUERY:" & vbCrLf & Prikaz, "PrikazSQL")
End Function
Code above is only part of the autonomous bot, on start it apply these settings:
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
DoEvents is used only for refreshing userform, instead of repaint.
I try to unload any object or variable, that i dont need, but i think i am missing something important. Any other part of code runs fine. Any help would be very appreciated.
Is there a possibility to have the HTML Body:
.HTMLBody = strText & RangetoHTML(rng) & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
...when criteria > 1 is fulfilled and ...
.HTMLBody = strText2 & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
' in this case the range is missing and the text is different when criteria = 0 is fulfilled.
I thought of the "if" function into the HTML Body?
GetBoiler Function:
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object, ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Range function:
Function RangetoHTML(rng As Range)
Dim fso As Object, ts As Object, TempWB As Workbook
With Worksheets("Auswertung")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("$A$7:$D$" & loLetzte).AutoFilter Field:=3, Criteria1:=">0"
If .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1). _
SpecialCells(xlCellTypeVisible).Copy
Else
'copy only the strText2
End If
.AutoFilterMode = False
End With
End Function
Main Sub function:
Sub Mail_Klicken()
Dim olApp As Object, datDatum As Date, StrBody As String, intZeile As Integer
Dim OutMail As Object, rng As Range, strMailverteilerTo As String
Dim strText As String, strFilename As String, loLetzte As Long
strMailverteilerTo = "sdfgsdf#gmx.de"
strText = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & _
"-serif"";color:black'>hello,<br><br>hello fellows.<br><br>"
strText2 = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & _
"-serif"";color:black'>dfgfg,<br><br>gfgfgfgfg.<br><br>"
Application.DisplayAlerts = True
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.to = strMailverteilerTo
.Subject = "check"
strFilename = "Standard"
If Application.UserName = "asd" Then strFilename = "asd"
.HTMLBody = strText & RangetoHTML(rng) & "<br><br>" & _
GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & _
strFilename & ".htm")
.Display
End With
Set olApp = Nothing
End Sub
You cant, AFAIK, put a statement like that since its expecting a string argument, here's one way you can do it is to call a function that builds the string,
Set olApp = CreateObject("Outlook.Application")
setStrText criteria, strText, rng
With olApp.CreateItem(0)
'rest of your code
.HTMLBody = strText
'rest of your code
function setStrText(crit as integer, strTe as string, tmpRng as range)
if crit >= 1 then
strTe = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & "-serif"";color:black'>hello,<br><br>hello fellows.<br><br>" & RangetoHTML(tmpRng) & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
else
strTe = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & "-serif"";color:black'>dfgfg,<br><br>gfgfgfgfg.<br><br>" & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
end if
end function
I have a database that I am trying to send information contained on a form combined with selected items in a listbox to a table when the user clicks a Send button. I have the code setup that should copy my information but get a syntax error and I am not sure why... I have tried several different things and can't get it to work. I have included the code below:
Private Sub ctrSend_Click()
Dim intI As Integer
Dim lst As ListBox
Dim varItem As Variant
Set lst = Me![lstShipping]
With lst
If .ItemsSelected.count = 0 Then Exit Sub
For Each varItem In .ItemsSelected
CurrentDb.Execute "INSERT INTO ShipInv ([Order], [ShipDate], [BIN], [SKU], [Lot], [QtyProd])" _
"VALUES ('" & Me.[ctrSOrder] & "'," & Me.[ctrSDate] & ",'" & .Column(0, varItem) & "'," & .Column(1, varItem) & "," & .Column(2, varItem) & "," & .Column(3, varItem) & ");", dbFailOnError
Next
End With
End Sub
For a situation like this, I always reccommend using a string to hold the constructed SQL so that you can easily print the string to the immediate window to check how certain values have broken your SQL.
So, try adding
Dim strSQL As String
strSQL = "INSERT INTO ShipInv ([Order], [ShipDate], [BIN], [SKU], [Lot], [QtyProd])" _
"VALUES ('" & Me.[ctrSOrder] & "'," & Me.[ctrSDate] & ",'" & .Column(0, varItem) & "'," & .Column(1, varItem) & "," & .Column(2, varItem) & "," & .Column(3, varItem) & ");"
Debug.Print strSQL
CurrentDb.Execute strSQL 'remove dbFailOnError temporarily so that failure will stop code
My blind guess is that if ShipDate is a date field(not text), you'll need to format that value with Format(Me.[ctrSDate], "\#mm\/dd\/yyyy\#" before pasting it into the SQL.
I used a different approach and it works out great...
Private Sub ctrSend_Click()
Dim intI As Integer
Dim lst As ListBox
Dim varItem As Variant
Dim rst As DAO.Recordset
Set lst = Me![lstShipping]
Set rst = CurrentDb.OpenRecordset("ShipInv", dbOpenTable)
With lst
If .ItemsSelected.count = 0 Then Exit Sub
For Each varItem In .ItemsSelected
rst.AddNew
rst!Order = Me.[ctrSOrder]
rst!EntDate = Date
rst!ShipDate = Me.[ctrSDate]
rst!BIN = .Column(0, varItem)
rst!SKU = .Column(1, varItem)
rst!Lot = .Column(2, varItem)
rst!QtyProd = .Column(3, varItem)
rst.Update
Next
End With
rst.Close
Set rst = Nothing
MsgBox "Warehouse Inventory Updated", vbOKOnly, "Inventory Confirmation"
End Sub
I have a database. In this i have hundreds of tables,macros and forms.
No my problem is i have to find what all queries,macros that are related to specific table.
I'm using microsoft acess 2000.
But i even i tried objet dependencies in access 2007, it showed plenty of errors and close automatically.
Is this there any easy way to get this???
Thanks,
Shanmugam
You can try to execute SQL Query against system tables directly to get dependencies that are shown in 2003+ versions in more user-friendly way. I am not sure if that works on 2000 (it does in 2003+) but it is worth trying:
SELECT DISTINCT MSysObjects.Name
FROM MSysQueries INNER JOIN MSysObjects ON MSysQueries.ObjectId=MSysObjects.Id
WHERE (((MSysQueries.Name1) Like "*" & [TableName] & "*")) OR (((MSysQueries.Name2) Like "*" & [TableName] & "*"))
You may need to check if you have permissions to access system tables...
Hope this helps
You can buy third-party software that will do this for you, but I've never felt the need for that. Instead, I wrote a couple of procedures that will do this. They require a reference to DAO.
The first one (SearchQueries) searches the text of queries only and runs quite fast. The second (SearchDB) searches forms, macros, queries, reports, and code. It takes a bit longer but is very thorough. The usage should be pretty self-explanatory but ask questions if you're unsure of anything.
Here's the full text of the procedures:
Sub SearchQueries(SearchText As String, _
Optional ShowSQL As Boolean = False, _
Optional QryName As String = "*")
On Error Resume Next
Dim QDef As QueryDef
For Each QDef In CurrentDb.QueryDefs
If QDef.Name Like QryName Then
If InStr(QDef.SQL, SearchText) > 0 Then
Debug.Print QDef.Name
If ShowSQL Then Debug.Print QDef.SQL & vbCrLf
End If
End If
Next QDef
End Sub
'Updated: 1/19/09 Limit search by object name pattern
Sub SearchDB(SearchText As String, _
Optional ObjType As AcObjectType = acDefault, _
Optional ObjName As String = "*")
Dim db As Database, obj As AccessObject, Ctl As Control, Prop As Property
Dim Frm As Form, Rpt As Report, mdl As Module
Dim objLoaded As Boolean, Found As Boolean, Instances As Long
Dim SLine As Long, SCol As Long, ELine As Long, ECol As Long
On Error GoTo Err_SearchDB
Set db = CurrentDb
Application.Echo False
'===============================================
'Search queries
If ObjType = acDefault Or ObjType = acQuery Then
Debug.Print "Queries:"
SearchQueries SearchText, False, ObjName
Debug.Print vbCrLf
End If
'===============================================
'Search forms
If ObjType = acDefault Or ObjType = acForm Then
Debug.Print "Forms:"
On Error Resume Next
For Each obj In CurrentProject.AllForms
If obj.Name Like ObjName Then
objLoaded = obj.IsLoaded
If Not obj.IsLoaded Then DoCmd.OpenForm obj.Name, acDesign, , , , acHidden
Set Frm = Application.Forms(obj.Name)
For Each Prop In Frm.Properties
Err.Clear
If InStr(Prop.Value, SearchText) > 0 Then
If Err.Number = 0 Then
Debug.Print "Form: " & Frm.Name & _
" Property: " & Prop.Name & _
" Value: " & Prop.Value
End If
End If
Next Prop
If Frm.HasModule Then
SLine = 0: SCol = 0: ELine = 0: ECol = 0: Instances = 0
Found = Frm.Module.Find(SearchText, SLine, SCol, ELine, ECol)
Do Until Not Found
Instances = Instances + 1
SLine = ELine + 1: SCol = 0: ELine = 0: ECol = 0
Found = Frm.Module.Find(SearchText, SLine, SCol, ELine, ECol)
Loop
If Instances > 0 Then Debug.Print "Form: " & Frm.Name & _
" Module: " & Instances & " instances"
End If
For Each Ctl In Frm.Controls
For Each Prop In Ctl.Properties
Err.Clear
If InStr(Prop.Value, SearchText) > 0 Then
If Err.Number = 0 Then
Debug.Print "Form: " & Frm.Name & _
" Control: " & Ctl.Name & _
" Property: " & Prop.Name & _
" Value: " & Prop.Value
End If
End If
Next Prop
Next Ctl
Set Frm = Nothing
If Not objLoaded Then DoCmd.Close acForm, obj.Name, acSaveNo
DoEvents
End If
Next obj
On Error GoTo Err_SearchDB
Debug.Print vbCrLf
End If
'===============================================
'Search modules
If ObjType = acDefault Or ObjType = acModule Then
Debug.Print "Modules:"
For Each obj In CurrentProject.AllModules
If obj.Name Like ObjName Then
objLoaded = obj.IsLoaded
If Not objLoaded Then DoCmd.OpenModule obj.Name
Set mdl = Application.Modules(obj.Name)
SLine = 0: SCol = 0: ELine = 0: ECol = 0: Instances = 0
Found = mdl.Find(SearchText, SLine, SCol, ELine, ECol)
Do Until Not Found
Instances = Instances + 1
SLine = ELine + 1: SCol = 0: ELine = 0: ECol = 0
Found = mdl.Find(SearchText, SLine, SCol, ELine, ECol)
Loop
If Instances > 0 Then Debug.Print obj.Name & ": " & Instances & " instances"
Set mdl = Nothing
If Not objLoaded Then DoCmd.Close acModule, obj.Name
End If
Next obj
Debug.Print vbCrLf
End If
'===============================================
'Search macros
If ObjType = acDefault Or ObjType = acMacro Then
'Debug.Print "Macros:"
'Debug.Print vbCrLf
End If
'===============================================
'Search reports
If ObjType = acDefault Or ObjType = acReport Then
Debug.Print "Reports:"
On Error Resume Next
For Each obj In CurrentProject.AllReports
If obj.Name Like ObjName Then
objLoaded = obj.IsLoaded
If Not obj.IsLoaded Then DoCmd.OpenReport obj.Name, acDesign
Set Rpt = Application.Reports(obj.Name)
For Each Prop In Rpt.Properties
Err.Clear
If InStr(Prop.Value, SearchText) > 0 Then
If Err.Number = 0 Then
Debug.Print "Report: " & Rpt.Name & _
" Property: " & Prop.Name & _
" Value: " & Prop.Value
End If
End If
Next Prop
If Rpt.HasModule Then
SLine = 0: SCol = 0: ELine = 0: ECol = 0: Instances = 0
Found = Rpt.Module.Find(SearchText, SLine, SCol, ELine, ECol)
Do Until Not Found
Instances = Instances + 1
SLine = ELine + 1: SCol = 0: ELine = 0: ECol = 0
Found = Rpt.Module.Find(SearchText, SLine, SCol, ELine, ECol)
Loop
If Instances > 0 Then Debug.Print "Report: " & Rpt.Name & _
" Module: " & Instances & " instances"
End If
For Each Ctl In Rpt.Controls
For Each Prop In Ctl.Properties
If InStr(Prop.Value, SearchText) > 0 Then
Debug.Print "Report: " & Rpt.Name & _
" Control: " & Ctl.Name & _
" Property: " & Prop.Name & _
" Value: " & Prop.Value
End If
Next Prop
Next Ctl
Set Rpt = Nothing
If Not objLoaded Then DoCmd.Close acReport, obj.Name, acSaveNo
DoEvents
End If
Next obj
On Error GoTo Err_SearchDB
Debug.Print vbCrLf
End If
Exit_SearchDB:
Application.Echo True
Exit Sub
Err_SearchDB:
Application.Echo True
Debug.Print Err.Description
Debug.Assert False
Resume
End Sub
For others who find this page as I did, below is a variation that includes occurences of a string, in all queries' tables or expressions. (This worked in both Access 2003 and Access 2013.)
SELECT DISTINCT
MSysObjects.Name, MSysQueries.Name1, MSysQueries.Name2, MSysQueries.Expression
FROM
MSysQueries
INNER JOIN
MSysObjects ON MSysQueries.ObjectId = MSysObjects.Id
WHERE
( (((MSysQueries.Name1) Like "*" & [String to search for] & "*"))
OR (((MSysQueries.Name2) Like "*" & [String to search for] & "*"))
OR (((MSysQueries.Expression) Like "*" & [String to search for] & "*")) )
And "Comment: You will be prompted once, for the [String to search for]"<>""
And "Comment: The starting point for this code came from link:"<>
"http://stackoverflow.com/questions/7831071/how-to-find-all-queries-related-to-table-in-ms-access# "
;
SELECT DISTINCT
MSysObjects.Name, MSysQueries.Name1, MSysQueries.Name2, MSysQueries.Expression
FROM
MSysQueries
INNER JOIN
MSysObjects ON MSysQueries.ObjectId = MSysObjects.Id;
This gave me a table of everything I was looking for. Thanks Igor.
Is there any way to bulk-export Microsoft Access code to files? I see I can export one file at a time, but there are hundreds and I'll be here all day. It there no "Export All" or multi-select export anywhere?
You can do this without having to write any code at all. From the menu, choose tools->analyze->database documenter.
This will give you a bunch of options to print out the code. You can then while viewing the report ether send it out to your PDF printer (if you have one). Or, simply print out to a text file printer. Or you can even then click on the word option in the report menu bar and the results will be sent out to word
The database documenter has provisions to print out all code, including code in forms.
So, in place of some of the suggested code examples you can do this without having to write any code at all. Do play with the additional options in the documenter. The documenter will produce HUGE volumes print out information for every single property and object in the database. So, if you don't un-check some of the options then you will easily empty a full size printer tray of paper. This documenter thus results in huge printouts.
To output all code to desktop, including code from forms and reports, you can paste this into a standard module and run it by pressing F5 or step through with F8. You may wish to fill in the name of the desktop folder first.
Sub AllCodeToDesktop()
''The reference for the FileSystemObject Object is Windows Script Host Object Model
''but it not necessary to add the reference for this procedure.
Dim fs As Object
Dim f As Object
Dim strMod As String
Dim mdl As Object
Dim i As Integer
Set fs = CreateObject("Scripting.FileSystemObject")
''Set up the file.
''SpFolder is a small function, but it would be better to fill in a
''path name instead of SpFolder(Desktop), eg "c:\users\somename\desktop"
Set f = fs.CreateTextFile(SpFolder(Desktop) & "\" _
& Replace(CurrentProject.Name, ".", "") & ".txt")
''For each component in the project ...
For Each mdl In VBE.ActiveVBProject.VBComponents
''using the count of lines ...
i = VBE.ActiveVBProject.VBComponents(mdl.Name).CodeModule.CountOfLines
''put the code in a string ...
If i > 0 Then
strMod = VBE.ActiveVBProject.VBComponents(mdl.Name).codemodule.Lines(1, i)
End If
''and then write it to a file, first marking the start with
''some equal signs and the component name.
f.writeline String(15, "=") & vbCrLf & mdl.Name _
& vbCrLf & String(15, "=") & vbCrLf & strMod
Next
''Close eveything
f.Close
Set fs = Nothing
End Sub
To get special folders, you can use the list supplied by Microsoft.
Enumerating Special Folders: http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_higv.mspx?mfr=true
From: http://wiki.lessthandot.com/index.php/Code_and_Code_Windows
There is nothing in the interface to export more than one module at a time.
You can code your own "export all" equivalent easily:
Public Sub ExportModules()
Const cstrExtension As String = ".bas"
Dim objModule As Object
Dim strFolder As String
Dim strDestination As String
strFolder = CurrentProject.Path
For Each objModule In CurrentProject.AllModules
strDestination = strFolder & Chr(92) & objModule.Name & cstrExtension
Application.SaveAsText acModule, objModule.Name, strDestination
Next objModule
End Sub
Here's my version:
'============================================================'
' OutputCodeModules for Access
' Don Jewett, verion 2014.11.10
' Exports the following items from an Access database
' Modules
' Form Modules
' Report Modules
'
' Must be imported into Access database and run from there
'============================================================'
Option Explicit
Option Compare Database
Private Const KEY_MODULES As String = "Modules"
Private Const KEY_FORMS As String = "Forms"
Private Const KEY_REPORTS As String = "Reports"
Private m_bCancel As Boolean
Private m_sLogPath As String
'------------------------------------------------------------'
' >>>>>> Run this using F5 or F8 <<<<<<<<
'------------------------------------------------------------'
Public Sub OutputModuleHelper()
OutputModules
End Sub
Public Sub OutputModules(Optional ByVal sFolder As String)
Dim nCount As Long
Dim nSuccessful As Long
Dim sLine As String
Dim sMessage As String
Dim sFile As String
If sFolder = "" Then
sFolder = Left$(CurrentDb.Name, InStrRev(CurrentDb.Name, "\") - 1)
sFolder = InputBox("Enter folder for files", "Output Code", sFolder)
If sFolder = "" Then
Exit Sub
End If
End If
'normalize root path by removing trailing back-slash
If Right(sFolder, 1) = "\" Then
sFolder = Left(sFolder, Len(sFolder) - 1)
End If
'make sure this folder exists
If Not isDir(sFolder) Then
MsgBox "Folder does not exist", vbExclamation Or vbOKOnly
Exit Sub
End If
'get a new log filename
m_sLogPath = sFolder & "\_log-" & Format(Date, "yyyy-MM-dd-nn-mm-ss") & ".txt"
sLine = CurrentDb.Name
writeLog sLine
sMessage = sLine & vbCrLf
sLine = Format(Now, "yyyy-MM-dd nn:mm:ss") & vbCrLf
writeLog sLine
sMessage = sMessage & sLine & vbCrLf
'output modules
nCount = CurrentDb.Containers(KEY_MODULES).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_MODULES)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & KEY_MODULES & " exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
'output form modules
If Not m_bCancel Then
nCount = CurrentDb.Containers(KEY_FORMS).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_FORMS)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Form Modules exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
End If
'output report modules
If Not m_bCancel Then
nCount = CurrentDb.Containers(KEY_REPORTS).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_REPORTS)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Report Modules exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
End If
If Len(sMessage) Then
MsgBox sMessage, vbInformation Or vbOKOnly, "OutputModules"
End If
End Sub
Private Function outputContainerModules( _
ByVal sFolder As String, _
ByVal sKey As String) As Long
Dim n As Long
Dim nCount As Long
Dim sName As String
Dim sPath As String
On Error GoTo EH
'refactored this to use reference to Documents,
'but the object reference doesn't stick around
'and I had to roll back to this which isn't as pretty.
'but this works (and if it ain't broke...)
For n = 0 To CurrentDb.Containers(sKey).Documents.Count - 1
nCount = nCount + 1
sName = CurrentDb.Containers(sKey).Documents(n).Name
Select Case sKey
Case KEY_FORMS
sName = "Form_" & sName
Case KEY_REPORTS
sName = "Report_" & sName
End Select
sPath = sFolder & "\" & sName & ".txt"
DoCmd.OutputTo acOutputModule, sName, acFormatTXT, sPath, False
Next 'n
outputContainerModules = nCount
Exit Function
EH:
nCount = nCount - 1
Select Case Err.Number
Case 2289 'can't output the module in the requested format.
'TODO: research - I think this happens when a Form/Report doesn't have a module
Resume Next
Case Else
Dim sMessage As String
writeError Err, sKey, sName, nCount
sMessage = "An Error ocurred outputting " & sKey & ": " & sName & vbCrLf & vbCrLf _
& "Number " & Err.Number & vbCrLf _
& "Description:" & Err.Description & vbCrLf & vbCrLf _
& "Click [Yes] to continue with export or [No] to stop."
If vbYes = MsgBox(sMessage, vbQuestion Or vbYesNo Or vbDefaultButton2, "Error") Then
Resume Next
Else
m_bCancel = True
outputContainerModules = nCount
End If
End Select
End Function
Private Function writeFile( _
ByVal sPath As String, _
ByRef sMessage As String, _
Optional ByVal bAppend As Boolean) As Boolean
'Dim oFSO as Object
'Dim oStream as Object
'Const ForWriting As Long = 2
'Const ForAppending As Long = 8
'Dim eFlags As Long
Dim oFSO As FileSystemObject
Dim oStream As TextStream
Dim eFlags As IOMode
On Error GoTo EH
'Set oFSO = Server.CreateObject("Scripting.FileSystemObject")
Set oFSO = New FileSystemObject
If bAppend Then
eFlags = ForAppending
Else
eFlags = ForWriting
End If
Set oStream = oFSO.OpenTextFile(sPath, eFlags, True)
oStream.WriteLine sMessage
writeFile = True
GoTo CLEAN
EH:
writeFile = False
CLEAN:
If Not oFSO Is Nothing Then
Set oFSO = Nothing
End If
If Not oStream Is Nothing Then
Set oStream = Nothing
End If
End Function
Private Sub writeError( _
ByRef oErr As ErrObject, _
ByVal sType As String, _
ByVal sName As String, _
ByVal nCount As Long)
Dim sMessage As String
sMessage = "An Error ocurred outputting " & sType & ": " & sName & " (" & nCount & ")" & vbCrLf _
& "Number " & oErr.Number & vbCrLf _
& "Description:" & oErr.Description & vbCrLf & vbCrLf
writeLog sMessage
End Sub
Private Sub writeLog( _
ByRef sMessage As String)
On Error GoTo EH
writeFile m_sLogPath, sMessage & vbCrLf, True
Exit Sub
EH:
'swallow errors?
End Sub
Private Function isDir(ByVal sPath As String) As Boolean
On Error GoTo EH
If Right$(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If Dir$(sPath & ".", vbDirectory) = "." Then
isDir = True
ElseIf Len(sPath) = 3 Then
If Dir$(sPath, vbVolume) = Left(sPath, 1) Then
isDir = True
End If
End If
Exit Function
EH:
isDir = False
End Function