I am trying to pull a list of names and email addresses from a tables in access and use that information to send out personalized emails. So I am trying to call 2 columns from access into an array and then using a loop to go through each row. I think this will be the best way to do it but i am open to other ideas. I have been able to generate code that produces one email with the first record, but i have no idea how to go about getting the rest of the records:
Private Sub SMT()
Application.Run "VariablesForRanges"
strDB1 = ThisWorkbook.Path & "\database.accdb"
strqry1 = "SELECT table1.name, table2.Email"
strqry1 = strqry1 & " FROM table2 inner join table1 on table1.FULL_NAME=table2.Name"
strqry1 = strqry1 & " group by table1.name, table2.Email;"
Set cn1 = New ADODB.Connection
cn1.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB1 & ";"
Set rs1 = New ADODB.Recordset
With rs1
Set .ActiveConnection = cn1
.Open strqry1
End With
If rs1.BOF = True Then
MsgBox "There Are No Records To Import", vbInformation
Else
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi " & rs1("name") & "," & vbNewLine & vbNewLine & _
"test" & vbNewLine & vbNewLine & _
"Best regards," & vbNewLine & _
On Error Resume Next
With OutMail
.To = rs1("Email")
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
End Sub
Any help with creating an array and loop would be appreciated. Thanks.
Why not just loop through the record set?
Do While Not rs1.EOF
' create emails
rs1.MoveNext
Loop
Related
I'm working on some code that checks a database for a specific value and returns a string under certain conditions.
I cannot get this code to iterate to the next row in my database results. It appears that my code only checks the first record of the recordset and then continues.
Sometimes my recordset may only have one row, but sometimes it may have many rows. If any of the rows of this recordset have a certain value I want to throw a MsgBox. Not just the first or last record.
Here's my code:
'Database Connection Strings.
strServerName = "string"
strDatabase = "string"
strUserName = "string"
strPassword = "string"
'Connection string for SQL Server.
strConn = "Driver={SQL Server};Server=" & strServerName & ";Database=" & strDatabase & ";Uid=" & strUsername & ";Pwd=" & strPassword & ";"
'Create required objects for the session.
Set WShell = CreateObject("WScript.Shell")
Set db = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
'Create the array of reciever lines and count them.
Set arrayLine = LINES.Value
intNumOfLines = arrayLine.Count
intLineNum = Cint(intNumOfLines)-1
cleanPN2 = array()
skipArray = array("-", " ", "PLATE", "HEAT-TREAT", "PAINT", "MACHINE", "WELD", "MPI")
result = MsgBox ("Scan PO for cert requirements?", vbYesNo, "PO Requirement Scanner")
Select Case result
Case vbYes
'Iterate through the reciever lines and look for part numbers.
For intLineNum = 0 To intNumOfLines
If intLineNum = intNumOfLines Then
Exit For
End If
Set arrayLine = LINES(intLineNum).Value
strPN = arrayLine("VENDOR_PART_ID")
cleanPN = split(strPN, " ")
For Each iteration in cleanPN
iteration = LTrim(RTrim(iteration))
ReDim Preserve cleanPN2(UBound(cleanPN2) + 1)
cleanPN2(UBound(cleanPN2)) = iteration
Next
Next
'Take any part numbers that were found and search the WO Master for operations that require certs.
For Each cleanPN3 In cleanPN2
strSQL = "SELECT USER_3 FROM OPERATION WHERE WORKORDER_BASE_ID = " & "'" & cleanPN3 & "';"
db.Open strConn, db
rs.Open strSQL, db
If Not rs.EOF And Not rs.BOF Then
strUSER3 = rs("USER_3")
Do While rs("USER_3") = Null
strUSER3 = rs("USER_3").MoveNext
Loop
If (strUSER3 <> Null) Or (strUSER3 <> "") Then
MsgBox "Certifications are required for part number " & cleanPN3 & "!", vbOKOnly
End If
End If
rs.Close
db.Close
Next
MsgBox "PO Scan Complete!"
Case vbNo
MsgBox("PO Scan Cancelled!")
End Select
Assuming everything else is working as you wish
rs.Open strSQL, db
If Not rs.BOF Then
rs.MoveFirst
Do While Not rs.EOF
If Len(Trim(Cstr(rs.fields("USER_3").value)) > 0 Then
MsgBox "Certifications are required for part number " & cleanPN3 & "!", vbOKOnly
End If
rs.MoveNext
Loop
End If
rs.Close
I have been working on passing store procedures in different scenarios. Currently, I am trying to call a SP via pass-through query inside the do-while loop. I have a SP named usp_MovePending and a pass-through query qryPending. I have a code with do-while loop in which I have to call the SP.
Public Sub Import()
On Error Resume Next
Dim DB As Database
Dim rs As Recordset
Dim UserStr As String
Dim ROG As Date
Dim qdf As QueryDef
Dim sql As String
UserStr = sqlfixup(CurrentUser())
Set DB = CodeDb
Set rs = DB.OpenRecordset("select * from tblQty where materialid <> 0")
DoCmd.Hourglass True
Set qdf = DB.CreateQueryDef("")
qdf.Connect = SQLConnectString
qdf.ReturnsRecords = True
Do While rs.EOF = False
With MatManagement.Transactions
.BeginTransaction
.TransactionClassID = 1
.MaterialID = rs!MaterialID
.TransactionCreateUser = CurrentUser()
.TransactionDate = Date
.CommitTransaction
If .Failure <> True Or .TransactionID <> 0 Then
CodeDb.Execute "update tblMMTransactions set transNote = '" & sqlfixup(rs.Fields("note")) & "' where transactionid = " & .TransactionID, dbSeeChanges
End If
With CurrentDb.QueryDefs("qryPending")
.sql = "exec usp_MovePending #materialid=" & rs!MaterialID & ",#SysUser=" & " '" & UserStr & "'" & "," & " #ROG=getdate()" & ",#force= 1"
.Execute
End With
End With
rs.MoveNext
Loop
rs.Close
qdf.Close
DB.Close
DoCmd.Hourglass False
End Sub
In above code, I had added few lines of code in the old code which is shown as below:
With CurrentDb.QueryDefs("qryPending")
.sql = "exec usp_MovePending #materialid=" & rs!MaterialID & ",#SysUser=" & " '" & UserStr & "'" & "," & " #ROG=getdate()" & ",#force= 1"
.Execute
End With
When I debug my code, it retrieves the SP's parameter to pass-through query. But, I think my code is not calling SP (when I test SP by itself, it works just fine). I think SQL is waiting for some return values but Access is not returning anything. I tried different approaches but while researching many developers recommend to use this approach. Can anyone point out what I am missing out here?
Have you tried referencing the SP in VB rather than SQL?
With CurrentDb.QueryDefs("qryPending")
.sql = "exec " & usp_MovePending & " #materialid=" & rs!MaterialID & ",#SysUser=" & " '" & UserStr & "'" & "," & " #ROG=getdate()" & ",#force= 1"
.Execute
End With
What result does this give you?
Is the SP a global variable that the SQL can see? can you easily call it within the access query builder into a field? Or is it only seen by the VB code within a procedure?
In the below code, my second query will not insert into the SQL database, but the first one will update. I can copy the query (from the msgbox i added for testing) and paste it in SQL Server Management Studio, and it will execute fine. I also do not get any error messages back from SQL, though i'm not sure if that code is correct (it was copied + pasted from another source). Also, can i simplify the code to pass both queries at the same time?
Dim Conn As New System.Data.SqlClient.SqlConnection 'sql server datastream connection
Dim Cmd As New System.Data.SqlClient.SqlCommand 'sql command vars
Dim SqlQuery As String 'string var used to hold various SQL queries
Dim data As System.Data.SqlClient.SqlDataReader 'datareader object variable
Dim MVDataset As New DataSet
Dim MVDatatable As DataTable
Dim MVDatarow As DataRow
Private Sub MVUpdateButton_Click(sender As Object, e As EventArgs) Handles MVUpdateButton.Click
vbyn = MsgBox("Are you sure you want to update Tally Sheet Master Variables?" & vbCrLf & vbCrLf & "Changes to these variables will change the functionality of the Tally Sheet!", vbYesNo, )
Try
Select Case vbyn
Case vbNo
GoTo MVTableUpdateBypass
Case vbYes
'get new data from textboxes
Vers = TextBox1.Text
If TextBox2.Text = True Then
Testing = 1
Else
Testing = 0
End If
FlatFeeCharge = TextBox3.Text
PrepricingCharge = TextBox4.Text
SendMailAcct = TextBox5.Text
SendMailPW = TextBox6.Text
TestingEmail = TextBox7.Text
PrePricingEmail = TextBox8.Text
ImperataEmail = TextBox9.Text
'update existing active row to mark inactive
SqlQuery = "Update MasterVars set Active = 0 where PKEY = " & PKEY & ";"
MsgBox(SqlQuery)
If Conn.State = ConnectionState.Closed Then
Conn.ConnectionString = "Data Source=SQL01;Initial Catalog=TallySheet;Integrated Security=SSPI;"
End If
Conn.Open()
Dim MVDataAdapter As New SqlDataAdapter(SqlQuery, Conn)
Dim MVUpdateCommand As SqlCommand
MVUpdateCommand = New SqlCommand(SqlQuery)
MVDataAdapter.UpdateCommand = MVUpdateCommand
'insert new active row
SqlQuery = "Insert into MasterVars (Vers, Testing, FlatFeeCharge, PrePricingCharge, SendMailAcct, SendMailPW, TestingEmail, PrePricingEmail, ImperataEmail, DTS, UserName, Active) Values (" & "'" & Vers & "', " & Testing & ", '" & FlatFeeCharge & "'" & ", '" & PrepricingCharge & "'" & ", '" & SendMailAcct & "'" & ", '" & SendMailPW & "'" & ", '" & TestingEmail & "'" & ", '" & PrePricingEmail & "'" & ", '" & ImperataEmail & "'" & ", '" & Date.Now & "'," & "'QGDOMAIN\" & Environment.UserName & "'," & 1 & ");"
MsgBox(SqlQuery)
Dim MVInsertCommand As SqlCommand
MVInsertCommand = New SqlCommand(SqlQuery)
MVDataAdapter.InsertCommand = MVInsertCommand
MVDataAdapter.Fill(MVDataset, "MasterVars")
End Select
Catch ex As SqlException
Dim i As Integer
Dim errormessages As String
errormessages = ""
For i = 0 To ex.Errors.Count - 1
errormessages = errormessages & " " & ("Index #" & i.ToString() & ControlChars.NewLine _
& "Message: " & ex.Errors(i).Message & ControlChars.NewLine _
& "LineNumber: " & ex.Errors(i).LineNumber & ControlChars.NewLine _
& "Source: " & ex.Errors(i).Source & ControlChars.NewLine _
& "Procedure: " & ex.Errors(i).Procedure & ControlChars.NewLine)
Next i
Console.WriteLine(errorMessages.ToString())
End Try
'reload form with updated variables
Conn.Close()
Conn.Dispose()
MVTableUpdateBypass:
End Sub
The Fill method of the SqlDataAdapter executes the SelectCommand not the UpdateCommand or the InsertCommand. In any case these two commands (and the DeleteCommand) are executed when you call the Update method of the adapter.
Moreover the Update method runs the commands looking for rows changed/added/deleted in the DataTable/DataSet retrieved by the SelectCommand and works only for those rows.
But you don't need an SqlDataAdapter to execute your two queries. You should simply construct an SqlCommand with both texts separated by a semicolon and call ExecuteNonQuery
SqlQuery = "Update MasterVars set Active = 0 where PKEY = #key;" & _
"Insert into MasterVars (Vers, Testing, .....) VALUES (#p1, #o2, ....)"
Using Conn = New SqlConnection("Data Source=SQL01;......")
Using cmd = New SqlCommand(SqlQuery, Conn)
Conn.Open()
cmd.Parameters.Add("#key", SqlDbType.Int).Value = PKEY
cmd.Parameters.Add("#p1", SqlDbType.NVarChar).Value = vers
cmd.Parameters.Add("#p2", SqlDbType.Int).Value = testing
... and so on with other parameters ....
cmd.ExecuteNonQuery()
End Using
End Using
In this incomplete example (too many parameters to write down) I have concatenated the two sql texts in a single string and prepared it with parameter placeholders. Then I build the parameter collection with the exact datatypes required by your table and finally call ExecuteNonQuery to run everything on the database side.
Notice that is not needed to keep global objects like the connection or the command. It is always better to create a local variable, use and destroy it when done. In particular disposable objects like the connection and the command should always created in a Using block
We have a VBScript that downloads chunks of data from an SAP Business Object database into so-called slices, which are basically .csv files. The script worked perfectly so far, I haven't really had to look into it at all. But the failure now is this:
The script file section this error refers to is the dbConn.Execute(strSQL) line in the below code (5th from below).
What I tried so far, was to add these commands but they don't seem to solve anything:
'dbConn.ConnectionTimeout = 100
'dbConn.CommandTimeout = 100
The script itself (not all of it, I'm not sure the rest is needed):
Sub subRunFilesInFolder(strFolder)
Dim FSO, objFolder, objFiles
Dim i, intTS, intTS_file_start, ts, tsKillBefore, TS_file_start, strModelName
Dim dbConn, RST, RST2, strSQL
Dim strVBSmodel
Dim blRunIt
'INIs
strModelName = "bo_vbs_runner_1.5 "
strConn = "DRIVER={SQL Server};SERVER=EUBASEURCIREP01;UID=ser_login;PWD=ser_login;DATABASE=ser"
strComputer = FunstrComputerName
strBORunner = "\\Eubaseurcirep01\reporting\DEVELOPMENT\BO\Automation\Models\BO_auto_run.xlsb"
'Sets
Set dbConn = CreateObject("ADODB.Connection")
Set RST = CreateObject("ADODB.RecordSet")
Set RST2 = CreateObject("ADODB.RecordSet")
Set WshShell = WScript.CreateObject("WScript.Shell")
Set FSO = Wscript.CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strFolder)
Set objFiles = objFolder.Files
Set appExcel = CreateObject("Excel.Application")
'dbConn.ConnectionTimeout = 100
'dbConn.CommandTimeout = 100
strVBSmodel = strModelName & strComputer & " " & FunstrUserName & " " & funCurrProcessId & " " & FunGetProcessIDCurrentOfExcel(strComputer)
appExcel.Application.Visible = False
appExcel.Displayalerts = False
Set objBORunner = appExcel.Workbooks.Open(strBORunner)
dbConn.Open strConn
ts = FunGetServerNow(dbConn,RST)
tsKillBefore = DateAdd("N", -15, ts)
intTS = funTimeStampToInteger(FunGetServerNow(dbConn, RST))
'Get ReportDate
strSQL = "SELECT yyyymmdd FROM map.reportdate WHERE dtAct=cast(GETDATE() as DATE);"
RST.Open strSQL, dbConn
If RST.EOF Then
strReportDate="99991231"
Else
strReportDate=RST.fields(0).value
End If
RST.close
'Kill stucked excel and vbs processes
strSQL = "SELECT distinct * FROM [ser].[bo].[_log] WHERE [proc]='BO VBS' AND result_text='started' AND end_timestamp<" & funTimeStampToInteger(tsKillBefore) & _
" AND lower(model) like '% " & LCase(strComputer) & " %';"
RST.Open strSQL,dbConn
If RST.EOF Then 'Nothing to kill
Else
Do While Not RST.EOF
strOldVBS = split(RST.fields("model"), " ")(3)
strOldExcel = split(RST.fields("model"), " ")(4)
Call SubKillProcessIDOnstrComputer(strComputer, strOldVBS)
Call SubKillProcessIDOnstrComputer(strComputer, strOldExcel)
strSQL = "UPDATE [ser].[bo].[_log] SET result_text='stopped', end_timestamp='" & funTimeStampToInteger(FunGetServerNow(dbConn,RST2)) & "' " & _
"WHERE [proc]='BO VBS' AND result_text='started' AND model='" & RST.fields("model").value & "' AND parameters='" & _
RST.fields("parameters").value & "';"
dbConn.Execute(strSQL)
RST.MoveNext
Loop
End If
RST.close
To Decode 0x8004nnnn Errors
HResults with facility code 4 means the HResult contains OLE errors (0x0 =
to 0x1ff) while the rest of the range (0x200 onwards) is component =
specific errors so 20e from one component will have a different meaning =
to 20e from another component.
You are lucky as your component is telling you it's OLDB with it's error - TIMEOUT
I have a lot of files stored as attached files in an Access db. I am going to move data to an SQL server and for that purpose I need to extract the attached files and turn them into file system files.
This snippet works fine for images and pdf files but not for Office documents like Word or Excel. I assume it has something to do with encoding, but I have no clues. Any ideas?
Dim dbs As Database
Dim rs As Recordset
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset("table1")
With rs
Do While Not .EOF
Set rsRec = rs.Fields("AttFiles").Value
While Not rsRec.EOF
NameOfFile = "C:\temp\" & rsFil.Fields("FileName")
Open NameOfFile For Binary Access Write As #1
Put #1, , rsRec.Fields("FileData").Value
Close #1
rsRec.MoveNext
Wend
.MoveNext
Loop
End With
rs.Close
dbs.Close
If the File is actually an attachment type, then you might as well use the Recordset2 of the Microsoft Access Object Library. Something like,
Public Sub exportDocument(tableName As String, fieldName As String, uniqueID As Long)
On Error GoTo Err_SaveImage
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
Dim saveAsName As String
Set rsParent = CurrentDb.OpenRecordset("SELECT " & tableName & ".* " & _
"FROM " & tableName & " WHERE " & tableName & "." & fieldName & " = " & uniqueID)
Set rsChild = rsParent.Fields("fileData").Value
If rsChild.RecordCount <> 0 Then
If Dir(Environ("userprofile") & "\My Documents\tmp\", vbDirectory) <> "." Then MkDir Environ("userprofile") & "\My Documents\tmp\"
saveAsName = Environ("userprofile") & "\My Documents\tmp\" & rsChild.Fields("FileName")
rsChild.Fields("fileData").SaveToFile saveAsName
FollowHyperlink saveAsName
End If
Exit_SaveImage:
Set rsChild = Nothing
Set rsParent = Nothing
Exit Sub
Err_SaveImage:
If Err = 3839 Then
Resume Next
Else
MsgBox "Some Other Error occured!" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description, vbCritical
Resume Exit_SaveImage
End If
End Sub
The above code will save the files to a location specified in saveAsName. I have specific unique ID in the WHERE condition. If you want to export all documents, you can alter the code accordingly, but might have to loop through the recordset. I hope this helps !