Hey I am trying to add a Second level to a tree view the First level being GroupName and the Second level being Description
I have this code but is just creating separate nodes for each instead oh being under different Groups names
Sub LoadGroupTree()
'**Loads Property List
' Initialise Error Checking
' Dimension Local Variables
Dim uRecSnap As ADODB.Recordset
Dim uPar As ADODB.Parameter
Dim uNode As TreeNode
' Dim iGroupID As Integer = 0
Dim uStackframe As New Diagnostics.StackFrame
Try
' Check For Open Connection
If uDBase Is Nothing Then
OpenConnection()
bConnection = True
End If
' Run Stored Procedure - Load Property List (Based on Search Value)
uCommand = New ADODB.Command
With uCommand
.ActiveConnection = uDBase
.CommandType = ADODB.CommandTypeEnum.adCmdStoredProc
.CommandTimeout = 0
uPar = .CreateParameter("#SearchValue", ADODB.DataTypeEnum.adVarChar, ADODB.ParameterDirectionEnum.adParamInput, 30)
.Parameters.Append(uPar)
.Parameters("#SearchValue").Value = txtFilter.Text
.CommandText = "InspsectionGroup_LoadRecords"
uRecSnap = .Execute
End With
' Suppress TreeView Repaint / Clear TreeView
tvwInspectionGroups.BeginUpdate()
tvwInspectionGroups.Nodes.Clear()
tvwInspectionGroups.ShowNodeToolTips = True
' Populate List
Do Until uRecSnap.EOF
uNode = tvwInspectionGroups.Nodes.Add("P" & Format(uRecSnap("InspectionGroupID").Value, "0000"), uRecSnap("GroupName").Value)
uNode.Tag = "P:" & Format(uRecSnap("InspectionGroupID").Value, "0000") & ":01:"
uNode.Nodes.Add("D" & Format(uRecSnap("GroupName").Value, "0000"), uRecSnap("Description").Value)
uNode.Tag = "D:" & Format(uRecSnap("GroupName").Value, "0000") & ":02:"
uNode.Nodes.Add("A" & Format(uRecSnap("Description").Value, "0000"), uRecSnap("AddressLine1").Value)
uNode.Tag = "A:" & Format(uRecSnap("Description").Value, "0000") & ":03:"
uRecSnap.MoveNext()
Loop
uRecSnap.Close()
' Repaint TreeView.
tvwInspectionGroups.EndUpdate()
tvwInspectionGroups.Refresh()
' Close Connection
Catch ex As Exception
' Catch Error
If Err.Number <> 0 Then
WriteAuditLogRecord(uStackframe.GetMethod.DeclaringType.FullName, uStackframe.GetMethod.Name.ToString, "Error", Err.Description & vbCrLf & vbCrLf & ex.StackTrace, 0)
MsgBox("System Error Ref: " & sAuditID & vbCrLf & uStackframe.GetMethod.DeclaringType.FullName & " / " & uStackframe.GetMethod.Name.ToString & vbCrLf & Err.Description & vbCrLf & vbCrLf & ex.StackTrace & Chr(13) & sErrDescription, MsgBoxStyle.Exclamation + MsgBoxStyle.OkOnly, "Business Management System - Unexepected Error Ref: " & sAuditID)
End If
Finally
If bConnection Then CloseConnection()
uRecSnap = Nothing
End Try
Sub LoadGroupTree()
'**Loads Property List
' Initialise Error Checking
' Dimension Local Variables
Dim uRecSnap As ADODB.Recordset
Dim uPar As ADODB.Parameter
Dim uNode As TreeNode
Dim uNode3 As TreeNode
' Dim iGroupID As Integer = 0
Dim uStackframe As New Diagnostics.StackFrame
Try
' Check For Open Connection
If uDBase Is Nothing Then
OpenConnection()
bConnection = True
End If
' Run Stored Procedure - Load Property List (Based on Search Value)
uCommand = New ADODB.Command
With uCommand
.ActiveConnection = uDBase
.CommandType = ADODB.CommandTypeEnum.adCmdStoredProc
.CommandTimeout = 0
uPar = .CreateParameter("#SearchValue", ADODB.DataTypeEnum.adVarChar, ADODB.ParameterDirectionEnum.adParamInput, 30)
.Parameters.Append(uPar)
.Parameters("#SearchValue").Value = txtFilter.Text
.CommandText = "InspsectionGroup_LoadRecords"
uRecSnap = .Execute
End With
' Suppress TreeView Repaint / Clear TreeView
tvwInspectionGroups.BeginUpdate()
tvwInspectionGroups.Nodes.Clear()
tvwInspectionGroups.ShowNodeToolTips = True
' Populate List
Do Until uRecSnap.EOF
uNode = tvwInspectionGroups.Nodes.Add("P" & Format(uRecSnap("InspectionGroupID").Value, "0000"), uRecSnap("GroupName").Value)
uNode.Tag = "P:" & Format(uRecSnap("InspectionGroupID").Value, "0000") & ":01:"
uNode3 = uNode.Nodes.Add("D" & Format(uRecSnap("GroupName").Value, "0000"), uRecSnap("Description").Value)
uNode.Tag = "D:" & Format(uRecSnap("GroupName").Value, "0000") & ":02:"
uNode3.Nodes.Add("A" & Format(uRecSnap("Description").Value, "0000"), uRecSnap("AddressLine1").Value)
uNode3.Tag = "A:" & Format(uRecSnap("Description").Value, "0000") & ":03:"
uRecSnap.MoveNext()
Loop
uRecSnap.Close()
' Repaint TreeView.
tvwInspectionGroups.EndUpdate()
tvwInspectionGroups.Refresh()
' Close Connection
Catch ex As Exception
' Catch Error
If Err.Number <> 0 Then
WriteAuditLogRecord(uStackframe.GetMethod.DeclaringType.FullName, uStackframe.GetMethod.Name.ToString, "Error", Err.Description & vbCrLf & vbCrLf & ex.StackTrace, 0)
MsgBox("System Error Ref: " & sAuditID & vbCrLf & uStackframe.GetMethod.DeclaringType.FullName & " / " & uStackframe.GetMethod.Name.ToString & vbCrLf & Err.Description & vbCrLf & vbCrLf & ex.StackTrace & Chr(13) & sErrDescription, MsgBoxStyle.Exclamation + MsgBoxStyle.OkOnly, "Business Management System - Unexepected Error Ref: " & sAuditID)
End If
Finally
If bConnection Then CloseConnection()
uRecSnap = Nothing
End Try
Related
We are trying to store new mail item components into excel and assign tkt id, have tried doing it with single shared mailbox and succeeded but we want to implement same for 20 shared mail boxes. how can outlook vba event/trigger identify as soon as new email arrives to one of the 20 shared mail boxes.
this is code which will only work for default inbox:
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
Dim cn As Object
Dim sCon As String
Dim sSQL As String
Dim bytHasAttachment As String
Dim strAddress As String
Dim objSender, exUser
Dim olRecipient As Outlook.Recipient
Dim strToEmails, strCcEmails, strBCcEmails As String
For Each olRecipient In Item.Recipients
Dim mail As String
If olRecipient.AddressEntry Is Nothing Then
mail = olRecipient.Address
ElseIf olRecipient.AddressEntry.GetExchangeUser Is Nothing Then
mail = olRecipient.Address
Else
mail = olRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
If olRecipient.Type = Outlook.OlMailRecipientType.olTo Then
strToEmails = strToEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olCC Then
strCcEmails = strCcEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olBCC Then
strBCcEmails = strBCcEmails + mail & ";"
End If
Next
With Item
If Item.Attachments.Count > 0 Then
bytHasAttachment = 1
Else
bytHasAttachment = 0
End If
End With
'On Error Resume Next 'PropertyAccessor can raise an exception if a property is not found
If Item.SenderEmailType = "SMTP" Then
strAddress = Item.SenderEmailAddress
Else
'read PidTagSenderSmtpAddress
strAddress = Item.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
If Len(strAddress) = 0 Then
Set objSender = Item.Sender
If Not (objSender Is Nothing) Then
'read PR_SMTP_ADDRESS_W
strAddress = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")
If Len(strAddress) = 0 Then
Set exUser = objSender.GetExchangeUser
If Not (exUser Is Nothing) Then
strAddress = exUser.PrimarySmtpAddress
End If
End If
End If
End If
End If
On Error GoTo ErrorHandler
Set cn = CreateObject("ADODB.Connection")
sCon = "Driver=MySQL ODBC 8.0 ANSI Driver;SERVER=localhost;UID=root;PWD={Platinum#123};DATABASE=liva_dev_gm;PORT=3306;COLUMN_SIZE_S32=1;DFLT_BIGINT_BIND_STR=1"
cn.Open sCon
sSQL = "INSERT INTO tbl_gmna_emailmaster_inbox (eMail_Icon, eMail_MessageID, eMail_Folder, eMail_Act_Subject, eMail_From, eMail_TO, eMail_CC, " & _
"eMail_BCC, eMail_Body, eMail_DateReceived, eMail_TimeReceived, eMail_Anti_Post_Meridiem, eMail_Importance, eMail_HasAttachment) " & _
"VALUES (""" & Item.MessageClass & """, " & _
"""" & Item.EntryID & """, " & _
"""Inbox""" & ", " & _
"""" & Item.Subject & """, " & _
"""" & strAddress & """, " & _
"""" & strToEmails & """, " & _
"""" & strCcEmails & """, " & _
"""" & strBCcEmails & """, " & _
"""" & Item.Body & """, " & "'" & Format(Item.ReceivedTime, "YYYY-MM-DD") & "', " & "'" & Format(Item.ReceivedTime, "hh:mm:ss") & "', " & "'" & Format(Item.ReceivedTime, "am/pm") & "', " & "'" & Item.Importance & "', " & "'" & bytHasAttachment & "')"
cn.Execute sSQL
End If
ExitNewItem:
bytHasAttachment = ""
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
If the 20 shared mailboxes are in the navigation pane.
Option Explicit
Private WithEvents inboxItms As Items
Private WithEvents sharedInboxItms1 As Items
' ...
Private WithEvents sharedInboxItms20 As Items
Private Sub Application_Startup()
Dim defaultInbox As Folder
Dim sharedMailbox1 As Folder
Dim sharedInbox1 As Folder
' ...
Dim sharedMailbox20 As Folder
Dim sharedInbox20 As Folder
Set defaultInbox = Session.GetDefaultFolder(olFolderInbox)
Set inboxItms = defaultInbox.Items
Set sharedMailbox1 = Session.Folders("SharedMailbox1#somewhere.com")
Set sharedInbox1 = sharedMailbox1.Folders("Inbox")
' typo fixed
'Set sharedInboxItms1 = sharedInbox1.Folders("Inbox").Items
Set sharedInboxItms1 = sharedInbox1.Items
' ...
Set sharedMailbox20 = Session.Folders("SharedMailbox20#somewhere.com")
Set sharedInbox20 = sharedMailbox20.Folders("Inbox")
' typo fixed
'Set sharedInboxItms20 = sharedInbox20.Folders("Inbox").Items
Set sharedInboxItms20 = sharedInbox20.Items
End Sub
Private Sub inboxItms_ItemAdd(ByVal Item As Object)
' current code for default inbox
End Sub
Private Sub sharedInboxItms1_ItemAdd(ByVal Item As Object)
inboxItms_ItemAdd Item
End Sub
' ...
Private Sub sharedInboxItms20_ItemAdd(ByVal Item As Object)
inboxItms_ItemAdd Item
End Sub
I have a problem with my code. I tried retrieving data from other Excel file. My code works but I received full data in one cell (A1). I'm sorry but I'm just beginner, believe that's the problem related to output, but I'm not find out why:
Sub RefreshData()
'Refresh data
Dim CreateNew As Object
Dim RunSELECT As Object
Dim Data As String
Dim SQL As String
FolderPath = ActiveWorkbook.path
path = Left(FolderPath, InStrRev(FolderPath, "\") - 1)
Set CreateNew = CreateObject("ADODB.Connection")
With CreateNew
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & path & "\Task1.xlsm; Extended Properties=Excel 12.0 Xml;HDR=YES;IMEX=1;CorruptLoad=xlRepairFile"
.Open
End With
'Run SQL
SQL = "SELECT * FROM [tw$]"
Set RunSELECT = CreateNew.Execute(SQL)
Do
output = output & RunSELECT(0) & ";" & RunSELECT(1) & ";" & RunSELECT(2) & vbNewLine
Debug.Print RunSELECT(0); ";" & RunSELECT(1) & ";" & RunSELECT(2)
RunSELECT.Movenext
Loop Until RunSELECT.EOF
ThisWorkbook.Worksheets("Dic").Range("A1").Value = output
RunSELECT.Close
CreateNew.Close
Set CreateNew = Nothing
Set RunSELECT = Nothing
End Sub
No need to wrap recordset values wtih semicolon delimiters using a Do loop. Simply use Range.CopyFromRecordset:
SQL = "SELECT * FROM [tw$]"
Set RunSELECT = CreateNew.Execute(SQL)
ThisWorkbook.Worksheets("Dic").Range("A1").CopyFromRecordset RunSELECT
RunSELECT.Close
CreateNew.Close
Set CreateNew = Nothing
Set RunSELECT = Nothing
ADOdb to Retrieve Data From Another Workbook (Without Opening It)
While playing around with Parfait's solution combined with a few posts, I came up with the function copySheetADOdb.
Adjust the constants under Source and Target in testCopySheetADOdb to test it.
The Code
Option Explicit
Sub testCopySheetADOdb()
' Initialize error handling.
Const ProcName = "testCopySheetADOdb"
On Error GoTo clearError ' Turn on error trapping.
' Source
Const Path As String = "F:\Test"
Const FileName As String = "Test.xlsx"
' Sheet Name ('SheetName') is case-insensitive i.e. 'A = a'.
Const SheetName As String = "Sheet1"
' Target
Const tgtName As String = "Sheet1"
Const tgtCell As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
' Define FilePath.
Dim FilePath As String
FilePath = Path & Application.PathSeparator & FileName
' Define Target Range.
Dim rng As Range
Set rng = wb.Worksheets(tgtName).Range(tgtCell)
' Test Result.
Dim Result As Boolean
Result = copySheetADODb(rng, FilePath, SheetName)
' Of course you can do all the above in one line:
'Result = copySheetADODB(Thisworkbook.Worksheets("Sheet1").Range("A1"), _
"C:\Test\Test.xlsx", "Sheet1")
' Inform user.
If Result Then
MsgBox "Worksheet successfully copied.", vbInformation, "Success"
Else
MsgBox "Worksheet not copied.", vbExclamation, "Failure"
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "':" & vbLf & " " & "Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
Function copySheetADOdb(TargetCellRange As Range, _
ByVal SourceFilePath As String, _
Optional ByVal SourceSheetName As String = "Sheet1") _
As Boolean
' Initialize error handling.
Const ProcName = "copySheetADOdb"
On Error GoTo clearError ' Turn on error trapping.
' Test Target Cell Range ('TargetCellRange').
If TargetCellRange Is Nothing Then
GoTo NoTargetCellRange
End If
If TargetCellRange.Rows.Count > 1 Or TargetCellRange.Columns.Count > 1 Then
GoTo OneCellOnly
End If
'
' Define SQL Generic String.
Const sqlGeneric As String = "SELECT * FROM [SheetName$]"
Dim conn As Object
Set conn = CreateObject("ADODB.Connection")
Dim strErr As String
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
' If you need the headers, HDR=NO means there are no headers
' (not: do not retrieve headers) so the complete data will be retrieved.
.ConnectionString = "Data Source='" _
& SourceFilePath _
& "';" _
& "Extended Properties='" _
& "Excel 12.0 Xml;" _
& "HDR=NO;" _
& "IMEX=1;" _
& "CorruptLoad=xlRepairFile" _
& "';"
On Error GoTo connOpenError
.Open
On Error GoTo clearError
' Run SQL.
Dim SQL As String
' Replace 'SheetName' in SQL Generic String
' with the actual sheet name ('SourceSheetName').
SQL = Replace(sqlGeneric, "SheetName", SourceSheetName)
Dim rs As Object
On Error GoTo connExecuteError
Set rs = .Execute(SQL)
On Error GoTo clearError
If Not TargetCellRange Is Nothing Then
' Copy sheet.
If Not rs.EOF Then
TargetCellRange.CopyFromRecordset rs
' Write result.
copySheetADOdb = True
Else
GoTo NoRecords
End If
End If
NoRecordsExit:
rs.Close
connExecuteExit:
.Close
End With
ProcExit:
Set rs = Nothing
connOpenExit:
Set conn = Nothing
Exit Function
NoTargetCellRange:
Debug.Print "'" & ProcName & "': " & "No Target Cell Range ('Nothing')."
GoTo ProcExit
OneCellOnly:
Debug.Print "'" & ProcName & "': " _
& "Target Cell Range has to be one cell range only."
GoTo ProcExit
NoRecords:
Debug.Print "'" & ProcName & "': No records found."
GoTo NoRecordsExit
connOpenError:
If Err.Number = "-2147467259" Then ' "-2147467259 (80004005)"
strErr = "'" & SourceFilePath & "' is not a valid path"
If Left(Err.Description, Len(strErr)) = strErr Then
Debug.Print "'" & ProcName & "': " & strErr & "..."
On Error GoTo 0 ' Turn off error trapping.
GoTo connOpenExit
End If
Else
GoTo clearError
End If
connExecuteError:
If Err.Number = "-2147467259" Then ' "-2147467259 (80004005)"
strErr = "'" & SourceSheetName & "' is not a valid name"
If Left(Err.Description, Len(strErr)) = strErr Then
Debug.Print "'" & ProcName & "': " & strErr & "..."
On Error GoTo 0 ' Turn off error trapping.
GoTo connExecuteExit
End If
Else
GoTo clearError
End If
clearError:
Debug.Print "'" & ProcName & "':" & vbLf & " " & "Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function
You have problem in this code:
ThisWorkbook.Worksheets("Dic").Range("A1").Value = output
you are yourself asking to save the output to A1 Cell.
I would suggest you use for or while loop to enter the data in cells according to your need.
We have a Front end app created in MS Access and a back-end supported by an Oracle database.
The users are required to upload an Excel file (around 6000 rows) every day and the process is done currently like this:
we have a temporary table where a VBA code is moving the excel data (the table is empty at every load)
once the file is uploaded another VBA code is pulling the data from that table and moves it using DAO to the server, line by line
The process takes a huge amount of time and we need to speed up the process.
The existing code with some adjustments and fields not presented here:
Public Function import_to_dwh_old_1() As Boolean
Dim rst As DAO.Recordset
Dim strSQL As String
Dim bol As Boolean
Dim strSQL_hr As Object
Dim rs As DAO.Recordset
Dim cnt As Integer
Dim i As Integer
Dim varReturn As Variant
Dim HR_ID As String
'######## 05/26/2019 - Fix to upload multiple times per day the HR file
db.Execute ("DELETE FROM DISPUTE_MGMT.DD_HR WHERE SNAPSHOT='" & Format(GetUTC(), "mm/dd/yyyy") & "'")
'######## End fix to upload ###########
bol = True
strSQL = "Select * FROM temp_hr"
Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot)
Set rs = db.OpenRecordset("DISPUTE_MGMT_DD_HR")
rst.MoveLast
rst.MoveFirst
cnt = rst.RecordCount
i = 1
Do While Not rst.EOF
On Error GoTo capture_error
'varReturn = SysCmd(acSysCmdSetStatus, "Uploading dispute " & i & " out of " & cnt & " for snapshot [" & Format(GetUTC(), "mm/dd/yyyy") & "]")
rs.AddNew
rs!USER_NAME = Environ("USERNAME")
rs!IS_DELETED = 0
rs!DATE_CREATED = GetUTC()
rs!DATE_MODIFIED = GetUTC()
rs!SNAPSHOT = Format(GetUTC(), "mm/dd/yyyy")
rs!HR_ID = rst!ID
'### deleted fields from code
rs.Update
rst.MoveNext
i = i + 1
Loop
varReturn = SysCmd(acSysCmdSetStatus, " ")
import_to_dwh = True
Exit Function
capture_error:
Debug.Print Err.Description
MsgBox Err.Description & " - HR_ID = " & HR_ID
varReturn = SysCmd(acSysCmdSetStatus, " ")
import_to_dwh = False
Exit Function
End Function
The new idea is more direct but I am not sure how to use in the same time a MS Access table and a SQL database table in the same statement
Public Function import_to_dwh() As Boolean
Dim qdf As DAO.QueryDef, rst As DAO.Recordset
Dim strSQL As String
On Error GoTo Error_Handler
Set qdf = CurrentDb.CreateQueryDef("")
If env = "prod" Then
qdf.Connect = prod_credentials
Else
qdf.Connect = dev_credentials
End If
'Delete current snapshot
qdf.SQL = "DELETE FROM DISPUTE_MGMT.DD_HR WHERE SNAPSHOT='" & Format(GetUTC(), "dd-mmm-yyyy") & "';"
Debug.Print qdf.SQL
qdf.ReturnsRecords = False
qdf.Execute
qdf.SQL = "INSERT INTO DISPUTE_MGMT.DD_HR (USER_NAME, IS_DELETED, DATE_CREATED, DATE_MODIFIED, SNAPSHOT, HR_ID) SELECT '" & Environ("USERNAME") & "', 0, to_date('" & GetUTC() & "','mm/dd/yyyy hh:mi:ss am'), to_date('" & GetUTC() & "','mm/dd/yyyy hh:mi:ss am'), " _
& "'" & Format(GetUTC(), "dd-mmm-yyyy") & "', ID FROM temp_hr;"
Debug.Print qdf.SQL
qdf.ReturnsRecords = False
qdf.Execute
Error_Handler_Exit:
On Error Resume Next
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
qdf.Close
Set qdf = Nothing
End If
import_to_dwh = True
'If Not db Is Nothing Then Set db = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Dim L As Long
For L = 0 To Errors.Count - 1
Debug.Print Errors(L) & " - " & Errors(L).Description
Next
import_to_dwh = False
Resume Error_Handler_Exit
End Function
Obviously, the second method does not work.. Could someone point me to the right direction?
Thank you!
Anybody out there that can help convert this small chunk of VB.NET to VBScript, I didn't realise when I was writing my tester app that the application I was going to use it in is all VBScript =(
The code gets a table from the database, then writes a couple of lines and then the table to a tab delimited file. I understand I may have to rewrite the part with Lambda completely? I may have to start again but if anyone can do this I would be appreciative!
Private dataTable As New DataTable()
Protected Sub Page_Load(sender As Object, e As EventArgs)
PullData()
End Sub
Public Sub PullData()
'Get data from DB into a DataTable
Using conn As New SqlConnection("Server=.\sqlexpress;Database=DB;User Id=User;Password=Password;")
Using cmd As New SqlCommand("SELECT areaID as 'Pond Number', storageDescription + SPACE(1) + areaID as 'Pond Name', " & vbCr & vbLf & "case when fishWeight = 0 then 0 else 1 end as 'Pondis Used', 1 as 'Volume', " & vbCr & vbLf & "FeedDensity AS 'Feed Density',round(cast(FeedDensity * revolution as float(25)),2)/*cast as float for correct rounding*/ AS 'Feed Multiplier'," & vbCr & vbLf & "feedType as 'Feed Type', feedName as 'Feed Name', batchID AS 'FishBatchCode'" & vbCr & vbLf & vbCr & vbLf & "FROM dbo.vwStorageMASTER" & vbCr & vbLf & vbCr & vbLf & "WHERE fkLocationID = 1 AND fkStorageIndicator <> 3 ORDER BY sequenceNumber ASC", conn)
conn.Open()
Dim da As New SqlDataAdapter(cmd)
da.Fill(dataTable)
End Using
End Using
'Output tab-delimited
Dim delim As String = vbTab
Dim sb = New StringBuilder()
sb.AppendLine("Trafalgar Master File" & vbCr & vbLf & vbCr & vbLf)
sb.AppendLine(String.Join(delim, "Number of Ponds: ", dataTable.Rows.Count.ToString() & vbCr & vbLf & vbCr & vbLf))
sb.AppendLine(String.Join(delim, dataTable.Columns.Cast(Of DataColumn)().[Select](Function(arg) arg.ColumnName)))
For Each dataRow As DataRow In dataTable.Rows
sb.AppendLine(String.Join(delim, dataRow.ItemArray.[Select](Function(arg) arg.ToString())))
Next
'Prompt user to download tab-delimited file
Dim FileName As String = "test.xls"
Dim response As System.Web.HttpResponse = System.Web.HttpContext.Current.Response
response.ClearContent()
response.Clear()
response.ContentType = "text/plain"
response.AddHeader("Content-Disposition", "attachment; filename=" & FileName & ";")
response.Write(sb.ToString())
response.Flush()
response.[End]()
End Sub
While VB.Net and VBScript share a similar syntax, the objects that they use are entirely different animals. Vbscript has no knowledge of System.Web, System.Data, StringBuilder, etc. Instead, you might want to look into the VB6 syntax and the late bound CreateObject syntax to create AdoDb objects.
This was how I rewrote it for my application. In the end I basically started again but it's result is pretty much the same;
<%#LANGUAGE="VBSCRIPT" CODEPAGE="1252"%>
<%Response.Buffer = True%>
<!--#include file="Conn/conn.asp" -->
<%
Call DownloadFile()
Private Sub DownloadFile()
Dim Comm
Dim rst
Dim delim
delim = vbTab
response.Clear
set rst = Server.CreateObject("ADODB.Recordset")
rst.ActiveConnection = MM_Conn_STRING
rst.Open "Select COUNT(*) from vwTrafalgarMasterFile"
'Write titles
Response.Write("Trafalgar Master File" & vbcrlf & vbcrlf)
Response.Write("Number of Ponds: " & rst.Fields(0).Value & vbcrlf & vbcrlf)
If rst.State = 1 Then rst.Close 'Used 1 instead of AdStateOpen as this seemed to cause an error
rst.Open "Select * from vwTrafalgarMasterFile"
'Write headers
If Not rst.EOF Then
For Each fld In rst.Fields
Response.Write(fld.Name & delim)
Next
Response.Write vbcrlf
Else
Response.Write("There was a problem retrieving data or no data could be retrieved")
Response.End
Exit sub
End if
'Write rows
With rst
.MoveFirst
Do Until .EOF
For Each fld In rst.Fields
Response.Write(fld.Value & delim)
Next
Response.Write vbcrlf
.Movenext
Loop
End With
Dim FileName
FileName = "TrafalgarMasterFile.xls"
response.ContentType = "text/plain"
response.AddHeader "Content-Disposition", "attachment; filename=" + FileName + ";"
response.Flush
response.End
'Clean up
adoCMD.Close
Set Comm = Nothing
Set rst = Nothing
Set fld = Nothing
End Sub
%>
I'm currently trying to do multiple inserts from an access database to a remote sql server. Thus far I've had no luck. When I attempt to code in a workspace and transactions I receive a data mismatch error, but the functional insert works perfectly fine separately.
Here is my code: Transaction One has been commented out
Private Sub cmdInsSqlSrvr_Click()
On Error GoTo ErrHandler
Dim dbAccess As DAO.Database
Dim strTableName As String
Dim strSQL As String
Dim strSqlServerDB As String
Dim strTableName2 As String
Dim cInTrans As Boolean
Dim wsp As DAO.Workspace
strTableName = "po_header_sql"
strTableName2 = "po_line_Sql"
'<configuration specific to SQL Server ODBC driver>
strSqlServerDB = "ODBC;DRIVER={SQL Server};" & _
"Server=;" & _
"DATABASE=;" & _
"Uid=;" & _
"Pwd=;"
'Start Transaction One
'Set dbAccess = DBEngine(0)(0)
' strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE3 SELECT * FROM " & strTableName & ";"
'dbAccess.Execute strSQL, dbFailOnError
'InitConnect = True
'MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
'Command9.SetFocus
'cmdInsSqlSrvr.Enabled = False
'cmdInsertTbl.Enabled = True
' End Transaction One
'Begin Transaction Two
Set wsp = DBEngine(0)(0)
wsp.BeginTrans
Set dbAccess = wsp(0)
cInTrans = True
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE4 SELECT * FROM " & strTableName2 & ";"
dbAccess.Execute strSQL, dbFailOnError
InitConnect = True
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
wsp.CommitTrans
cInTrans = False
Command9.SetFocus
cmdInsSqlSrvr.Enabled = False
cmdInsertTbl.Enabled = True
'End Transaction Two
ExitProcedure:
On Error Resume Next
Set dbAccess = Nothing
Exit Sub
ErrHandler:
InitConnect = False
MsgBox Err.Description, vbExclamation, "Moving data to Sql Server failed: Error " & Err.Number
Resume ExitProcedure
End Sub
Fixed it by separating the insert statements and putting dbAccess.Execute after each one. Also cleaned up the code substantially. Code follows:
Private Sub cmdInsSqlSrvr_Click()
On Error GoTo ErrHandler
Dim dbAccess As DAO.Database
Dim strTableName As String
Dim strSQL As String
Dim strSqlServerDB As String
Dim strTableName2 As String
strTableName = "po_header_sql"
strTableName2 = "po_line_Sql"
'<configuration specific to SQL Server ODBC driver>
strSqlServerDB = "ODBC;DRIVER={SQL Server};" & _
"Server=<server ip>;" & _
"DATABASE=<database name>;" & _
"Uid=<database uid>;" & _
"Pwd=<database password>;"
Set dbAccess = DBEngine(0)(0)
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE3 SELECT * FROM " & strTableName & ";"
dbAccess.Execute strSQL, dbFailOnError
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE4 SELECT * FROM " & strTableName2 & ";"
dbAccess.Execute strSQL, dbFailOnError
InitConnect = True
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName2 & " to remote DB")
Command9.SetFocus
cmdInsSqlSrvr.Enabled = False
cmdInsertTbl.Enabled = True
ExitProcedure:
On Error Resume Next
Set dbAccess = Nothing
Exit Sub
ErrHandler:
InitConnect = False
MsgBox Err.Description, vbExclamation, "Moving data to Sql Server failed: Error " & Err.Number
Resume ExitProcedure
End Sub