I have a VBS file that queries an access database and writes the results to a .CSV file. The only thing being written to the .CSV file is ÿþ.
I am using the same VBS file with a more complex query and it runs fine. Both queries return 2 fields of the same type. The only change between the 2 files is the SQL query. Also if I paste the query I'm trying to use into Access, it runs the query as expected.
Here is the VBS file:
Dim connStr, objConn, getNames, objFSO, rs
Const ForWriting = 2
'Make and open progress window
On Error Resume Next
Set objExplorer = CreateObject("InternetExplorer.Application")
objExplorer.Navigate "about:blank"
objExplorer.ToolBar = 0
objExplorer.StatusBar = 0
objExplorer.Width = 400
objExplorer.Height = 200
objExplorer.Visible = 1
objExplorer.Silent = 1
objExplorer.Document.Title = "Script in progress"
objExplorer.Document.Body.InnerHTML = "Your Script is being processed. " & "This might take several minutes to complete. Closing this window will stop the script. So don't close this window ^_^"
'Create csv file
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLogFile = objFSO.CreateTextFile("\\192.168.100.4\data\IT\Scripts\testData.csv", ForWriting, True)
'Define Db String
connStr = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=\\192.168.100.16\Sage\2016\Connex\Sage100Shadow_CHRIS.mdb"
'Define object type
Set objConn = CreateObject("ADODB.Connection")
'Open Connection
objConn.Open connStr
'Define recordset and SQL query
Set rs = objConn.Execute("SELECT [BillNo],[InStock] FROM qryKitInvNums;")
MsgBox(rs.Fields(0).Type & ", " & rs.Fields(1).Type)
'While loop, loops through all available results
Do While Not rs.EOF
'add values seperated by comma to getNames
getNames = rs.Fields(0) & "," & rs.Fields(1)
'Write current record to LogFile
objLogFile.Write getNames
'Line return for next record in LogFile
objLogFile.Writeline
'move to next result before looping again
rs.MoveNext
'continue loop
Loop
MsgBox(getNames)
'Close connection and release objects
objLogFile.Close
objConn.Close
Set rs = Nothing
Set objConn = Nothing
'Closes progress window
objExplorer.Document.Body.InnerHTML = "Your Script is now complete."
WScript.Sleep 2000
objExplorer.Quit
Here is a copy of the working VBS file. The only difference is the SQL query which still returns 2 fields of same type as the first VBS file.
Dim connStr, objConn, getNames, objFSO
Const ForWriting = 2
'Make and open progress window
On Error Resume Next
Set objExplorer = CreateObject("InternetExplorer.Application")
objExplorer.Navigate "about:blank"
objExplorer.ToolBar = 0
objExplorer.StatusBar = 0
objExplorer.Width = 400
objExplorer.Height = 200
objExplorer.Visible = 1
objExplorer.Silent = 1
objExplorer.Document.Title = "Script in progress"
objExplorer.Document.Body.InnerHTML = "Your Script is being processed. " & "This might take several minutes to complete. Closing this window will stop the script. So don't close this window ^_^"
'Create csv file
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLogFile = objFSO.CreateTextFile("\\192.168.100.4\data\IT\Scripts\testData.csv", ForWriting, True)
'Define Db String
connStr = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=\\192.168.100.16\Sage\2016\Connex\Sage100Shadow_CHRIS.mdb"
'Define object type
Set objConn = CreateObject("ADODB.Connection")
'Open Connection
objConn.Open connStr
'Define recordset and SQL query
Set rs = objConn.Execute("SELECT IM_ItemWarehouse.ItemCode, IIf([InStock] Is Null Or [InStock]="""",[IM_ItemWarehouse].[QuantityOnHand],[InStock]) AS EvalInstock FROM IM_ItemWarehouse LEFT JOIN qryInStockNum4ItemsWPO ON IM_ItemWarehouse.ItemCode = qryInStockNum4ItemsWPO.ItemCode WHERE (((IM_ItemWarehouse.ItemCode) Is Not Null) AND ((IM_ItemWarehouse.WarehouseCode)=""000""));")
'While loop, loops through all available results
Do While Not rs.EOF
'add values seperated by comma to getNames
getNames = rs.Fields(0) & "," & rs.Fields(1)
'Write current record to LogFile
objLogFile.Write getNames
'Line return for next record in LogFile
objLogFile.Writeline
'move to next result before looping again
rs.MoveNext
'continue loop
Loop
'Close connection and release objects
objLogFile.Close
objConn.Close
Set rs = Nothing
Set objConn = Nothing
'Closes progress window
objExplorer.Document.Body.InnerHTML = "Your Script is now complete."
WScript.Sleep 2000
objExplorer.Quit
Related
I have a vbs script that's failing to finish loading a file before moving on to the next steps. I've been using this code for 2+ years so this is likely due to my poor code and error handling - If the SSIS package fails to fully load, the procedure should kick out and alert me - Can someone point me in the right direction to make sure this package fully loads or if it fails, truncate the stage table and try again?
The file can range from 50mb to 1.2Gb
'******************************
Sub ReloadTable(strTableName)
'******************************
Dim wsh
Set wsh = CreateObject("WScript.Shell")
Dim waitOnReturn
waitOnReturn = True
Dim windowStyle
windowStyle = 0
Dim errorCode
Dim DTEXECStatus
'Truncate the stage table
ExecOnSQL "TRUNCATE TABLE essstage." & strTableName
'Run the SSIS package and wait until complete
errorCode = wsh.Run("dtexec /File ""\\server.dev.local\Data\SSIS SQL16\" & strTableName & ".dtsx"" ", windowStyle, waitOnReturn)
If errorCode = 0 Then
DTEXECStatus = "Success! " & strTableName
'MsgBox "Success! " & strTableName
Else
'Should exit the sub if this fails and notify me
DTEXECStatus = "FAILED!! " & strTableName
Create_NOTICE_Email
MsgBox "Failed! " & strTableName
'It'd be better if this repeated the steps to clear/attempt to reload again but who knows how to do that
Exit Sub
'ML: Added this END to the script to see if it'll stop erroring out
End If
End Sub
'******************************
Sub ExecOnSQL(cmdTxt)
'******************************
Dim strConnSQL
strConnSQL = "Provider=SQLOLEDB; Server=SQLSERVER.dev.LOCAL; Database=goldmouse; Trusted_Connection=Yes"
'Open the connection to the database
Dim cn
Set cn = CreateObject("ADODB.Connection")
cn.Open strConnSQL
'Set the command
Dim cmd
Set cmd = CreateObject("ADODB.Command")
Set cmd.ActiveConnection = cn
'Set the record Set
Dim rs
Set rs = CreateObject("ADODB.recordSet")
'Prepare the command
cmd.CommandText = cmdTxt
cmd.CommandType = 1 'adCmdText
cmd.CommandTimeout = 3000 '50 minutes
'cmd.CommandType = 4 'adCmdStoredProc
'Execute the command
Set rs = cmd.Execute
Set cmd = Nothing
'Close connections
cn.Close
Set cn = Nothing
End Sub
I am currently trying to download many .doc files that are attached to the Microsoft Access record under the "Attachment" field which is labeled as "File/Attachment". However, I need the ability to run a query (Search By Loss Incident) which I did prior and then run the macro to download ALL the attachments from multiple records. This is my code below, I need some help with it! I am getting an error of "This expression you entered has a function containing the wrong number of arguments".
Option Compare Database
Public Function SaveAttachmentsTest(strPath As String, Optional strPattern As String = "*.*") As Long
Dim dbs As DAO.database
Dim rst As DAO.Recordset
Dim rsA As DAO.Recordset2
Dim fld As DAO.Field2
Dim strFullPath As String
'Get the database, recordset, and attachment field
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Search By Loss Incident Name")
Set fld = rst("File/Attachment")
'Navigate through the table
Do While Not rst.EOF
'Get the recordset for the Attachments field
Set rsA = fld.Value
'Save all attachments in the field
Do While Not rsA.EOF
If rsA("FileName") Like strPattern Then
'To Export the data, use the line below
strFullPath = "C:\Users\Emmanuel\Desktop\Test" & "\" & rsA("FileName")
'Make sure the file does not exist and save
If Dir(strFullPath) = "" Then
rsA("FileData").SaveToFile strFullPath
End If
'Increment the number of files saved
SaveAttachmentsTest = SaveAttachmentsTest + 1
End If
'Next attachment
rsA.MoveNext
Loop
rsA.Close
'Next record
rst.MoveNext
Loop
rst.Close
dbs.Close
Set fld = Nothing
Set rsA = Nothing
Set rst = Nothing
Set dbs = Nothing
End Function
Introduce a local variable:
<snip>
Dim SavedAttachments As Long
<snip>
' Increment the number of files saved.
SaveAttachments = SaveAttachments + 1
End If
<snip>
Set fld = Nothing
Set rsA = Nothing
Set rst = Nothing
Set dbs = Nothing
' Return the count of saved files.
SaveAttachmentsTest = SaveAttachments
End Function
I am trying to create VBscript to export process data from a SCADA system (WinCC RT Professional) to periodically archive all process variables. The data are stored in SQL table that can be accessed through a connectivity pack. I managed to make the script working when exporting one tag (process variable), but I would like to loop over all tags in the system (about 60), collect them in another recordset and then all data from this recordset save in one csv-file. I have created RecSet that collects all variables (fields) of one tag (Time, Process Variable etc.), I only need values from Field 4 (the same field for all tags). I would then like to copy this field in another recordset - RecSetColl which collects all required data (Field 4) from all tags and finally save them in the CSV file. Thank you very much for any help.
Sub DataExport()
Dim fso 'FileSystemObject
Dim f 'File
Dim ts 'TextStream
Dim path 'Path
Dim ArchiveDate 'Archive date
'Name of CSV-file
ArchiveDate = ArchiveDate & Now
ArchiveDate = Replace(ArchiveDate,"/","")
ArchiveDate = Replace(ArchiveDate," ","")
ArchiveDate = Replace(ArchiveDate,":","")
ArchiveDate = "MDF_" & ArchiveDate
'Path to the csv-file
path = "D:\Historical_data\" & ArchiveDate & ".csv"
'Create Filesystemobject and CSV-file if not exists:
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(path) Then
fso.CreateTextFile(path)
Else
MsgBox "File already exists!"
Exit Sub
End If
'Create object and open it for writing
Set f = fso.GetFile(path)
Set ts = f.OpenAsTextStream(2,-2)
ts.WriteLine("Tag-Name;ValueID;Date/Time;Process-Value") 'Header
'Generate String for the CSV-Filename
Dim Pro 'Provider
Dim DSN 'Data Source Name
Dim DS 'Data Source
Dim ConnString 'Connection String
Dim MachineNameRT 'Name of the PC from WinCC-RT
Dim DSNRT 'Data Source Name from WinnCC-RT
Dim Conn 'Connection to ADODB
Dim RecSet 'RecordSet
Dim RecSetColl 'RecordSet storing data to be saved to the CSV-file
Dim Command 'Query
Dim CommandText 'Command-Text
Dim i
'Read the name of the PC-Station and the DSN-Name from WinCC-RT
Set MachineNameRT = HMIRuntime.Tags("#LocalMachineName")
Set DSNRT = HMIRuntime.Tags("#DatasourceNameRT")
'Preparing the Connection-String
Pro = "Provider=WinCCOLEDBProvider.1;" 'First instance of WinCCOLEDB
DSN = "Catalog=" & DSNRT.Read & ";" 'Name of Runtime-Database
DS = "Data Source=" & MachineNameRT.Read & "\WinCC" 'Data Source
'Build the complete String:
ConnString = Pro + DSN + DS
'Make Connection
Set Conn = CreateObject("ADODB.Connection")
Conn.ConnectionString = ConnString
Conn.CursorLocation = 3
Conn.open
Set RecSetColl = CreateObject("ADODB.Recordset")
With RecSetColl.Fields
.Append "Time1", adChar
.Append "AHU_RUN", adChar
.Append "Time2", adChar
.Append "TT01", adChar
.Append "TT02", adChar
End With
For i = 0 To 4
Set RecSet = CreateObject("ADODB.Recordset")
Set Command = CreateObject("ADODB.Command")
Command.CommandType = 1
Set Command.ActiveConnection = Conn
'Building the complete string
CommandText = "Tag:R," & i & ",'0000-00-00 12:00:00.000','0000-00-00 00:00:00.000'"
Command.CommandText = CommandText
Set RecSet = Command.Execute
RecSet.MoveFirst
RecSetColl.Fields(i) = RecSet.Fields(4) 'RecSet.Fields(4) stores a proces value
RecSet.Close
Set RecSet = Nothing
Set Command = Nothing
Next
'Writing recordsets to CSV-file
Do While Not RecSetColl.EOF
ts.WriteLine (RecSetColl.Fields(0).Value & ";" & RecSetColl.Fields(1).Value & ";" & RecSetColl.Fields(2).Value & ";" & RecSetColl.Fields(3).Value & ";" & RecSetColl.Fields(4).Value & ";" & RecSetColl.Fields(5).Value)
RecSetColl.MoveNext
Loop
RecSetColl.Close
Set RecSetColl = Nothing
Conn.close
Set Conn = Nothing
ts.Close
Set fso = Nothing
Set f = Nothing
Set ts = Nothing
End Sub
I do not really know whats not working, but a guess;
Does ValueID = 0 , (the "i" in the "for 0 to 4" ) exist in your project?
In the table "Archive" you will find the valid ValueIDs, starts with "1" in all my projects. It's simple to see in SQL Management Studio, perhaps sometimes 0 exist.
To get all the values exported, query the "Archive" table first and then ask for data in a loop using whatever ValueID's is returned.
//PerD
I want to have a button on the Excel spreadsheet and have the data copied to the Access table.
The range is an auto-populated field from another sheet in the same workbook.
I tried few codes to make this happen, but I either get an error 1004: application-defined or object-defined error, or no error but data not being copied in Access DB.
My code is copied below.
Sub Export_Data()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim dbPath
Dim x As Long, i As Long
dbPath = "H:\RFD\RequestForData.accdb"
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.Open Source:="tblRequests", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
rst.AddNew
For i = 1 To 13
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
MsgBox " The data has been successfully sent to the access database"
Set rst = Nothing
Set cnn = Nothing
End Sub
Looking at your Subroutine I see two things that can make it not to work:
rst(Cells(1, i).Value) = Cells(x, i).Value <- Where is 'x' initialized?
There is only one loop that moves over the fields but I think it should be another loop for the rows in the Excel.
With this two changes, the loop when the records are save could become something like this:
For x = 1 TO lastRow ' Last row has to be calculated somehow
rst.AddNew
For i = 1 To 13
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
Next x
Hope it helps.
I have a query "myQuery" that returns more than 65,000 records, and as such, cannot be exported to one .xlsx file.
I'm attempting to break up this output to multiple files.
I'm still very much a beginner with VBA, but I've put the following together as best I can from research. This code is intended to iterate through the queried data, then output a new file for each 65,000 records.
Private Sub btnfrm1export_Click()
Dim outputFileName As String
Dim dlgOpen As FileDialog
Dim numFiles As Integer
Dim rs As String
Dim numr As Integer
Dim sql As String
Dim rec As Recordset
'Allows user to pick destination for files and gives value to sItem.
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then
sItem = .SelectedItems(1)
End If
End With
'Counts the records in myQuery to give the number of files needed to numFiles, assuming 60,000 records per file.
Set rec = CurrentDb.OpenRecordset("myQuery")
numFiles = Round(rec.RecordCount / 60000, 0)
numr = 1
' Changes the SQL of the query _vba in the current Database to select 60000 records from myQuery
rs = "SELECT TOP 60000 myQuery.* FROM myQuery"
CurrentDb.QueryDefs("_vba").sql = rs
'Defines SQL for clearing top 60000 (used in the following loop).
sql = "DELETE TOP 60000 myQuery.* FROM myQuery"
'Loops once to create each file needed
Do While numFiles > 0
'Sets a file name based on the destination folder, the file number numr, and information from a combobutton cbo1 on Form frm1.
outputFileName = sItem & "\" & Forms!frm1!cbo1 & "_Report_Pt" & numr & "_" & Format(Date, "yyyyMMdd") & ".xlsx"
'Outputs top 60000 of myQuery records to an excel file.
DoCmd.OutputTo acOutputQuery, "_vba", acFormatXLSX, outputFileName
numFiles = numFiles - 1
numr = numr + 1
'Deletes top 60000 from myQuery.
CurrentDb.Execute sql
Loop
End Sub
However, I'm getting:
Run-time error '2302': Microsoft Access can't save the output data to the file you've selected.
at DoCmd.OutputTo acOutputQuery, "_vba", acFormatXLSX, outputFileName
I do need this to be automated in vba and without pop-ups, etc. Any suggestions to make my code more efficient and proper is appreciated, but the REAL question is how to eliminate the error with DoCmd.OutputTo or make this work.
Thanks for any and all help!
Although the subject line concerns trying to output multiple Excel files, the real issue is trying to create an Excel file from an Access table or query which contains more than 65,000 rows - by using VBA. If VBA is NOT a requirement, then you can export a query or table by right-clicking on the object name, selecting export, then Excel. DO NOT check the box for 'Export data with formatting...' and it will work.
The code shown below was found at: http://www.myengineeringworld.net/2013/01/export-large-access-tablequery-to-excel.html (Created By Christos Samaras) and will properly export a large table/query to Excel
Option Compare Database
Option Explicit
Sub Test()
'Change the names according to your own needs.
DataToExcel "Sample_Table", "Optional Workbook Path", "Optional Target Sheet Name"
'Just showing that the operation finished.
MsgBox "Data export finished successfully!", vbInformation, "Done"
End Sub
Function DataToExcel(strSourceName As String, Optional strWorkbookPath As String, Optional strTargetSheetName As String)
'Use this function to export a large table/query from your database to a new Excel workbook.
'You can also specify the name of the worksheet target.
'strSourceName is the name of the table/query you want to export to Excel.
'strWorkbookPath is the path of the workbook you want to export the data.
'strTargetSheetName is the desired name of the target sheet.
'By Christos Samaras
'http://www.myengineeringworld.net
Dim rst As DAO.Recordset
Dim excelApp As Object
Dim Wbk As Object
Dim sht As Object
Dim fldHeadings As DAO.Field
'Set the desired recordset (table/query).
Set rst = CurrentDb.OpenRecordset(strSourceName)
'Create a new Excel instance.
Set excelApp = CreateObject("Excel.Application")
On Error Resume Next
'Try to open the specified workbook. If there is no workbook specified
'(or if it cannot be opened) create a new one and rename the target sheet.
Set Wbk = excelApp.Workbooks.Open(strWorkbookPath)
If Err.Number <> 0 Or Len(strWorkbookPath) = 0 Then
Set Wbk = excelApp.Workbooks.Add
Set sht = Wbk.Worksheets("Sheet1")
If Len(strTargetSheetName) > 0 Then
sht.Name = Left(strTargetSheetName, 34)
End If
End If
'If the specified workbook has been opened correctly, then in order to avoid
'problems with other sheets that might contain, a new sheet is added and is
'being renamed according to the strTargetSheetName.
Set sht = Wbk.Worksheets.Add
If Len(strTargetSheetName) > 0 Then
sht.Name = Left(strTargetSheetName, 34)
End If
On Error GoTo 0
excelApp.Visible = True
On Error GoTo Errorhandler
'Write the headings in the target sheet.
For Each fldHeadings In rst.Fields
excelApp.ActiveCell = fldHeadings.Name
excelApp.ActiveCell.Offset(0, 1).Select
Next
'Copy the data in the target sheet.
rst.MoveFirst
sht.Range("A2").CopyFromRecordset rst
sht.Range("1:1").Select
'Format the headings of the target sheet.
excelApp.Selection.Font.Bold = True
With excelApp.Selection
.HorizontalAlignment = -4108 '= xlCenter in Excel.
.VerticalAlignment = -4108 '= xlCenter in Excel.
.WrapText = False
With .Font
.Name = "Arial"
.Size = 11
End With
End With
'Adjusting the columns width.
excelApp.ActiveSheet.Cells.EntireColumn.AutoFit
'Freeze the first row - headings.
With excelApp.ActiveWindow
.FreezePanes = False
.ScrollRow = 1
.ScrollColumn = 1
End With
sht.Rows("2:2").Select
excelApp.ActiveWindow.FreezePanes = True
'Change the tab color of the target sheet.
With sht
.Tab.Color = RGB(255, 0, 0)
.Range("A1").Select
End With
'Close the recordset.
rst.Close
Set rst = Nothing
Exit Function
Errorhandler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Exit Function
End Function