I am trying to call a value from a form to put it on SQL. But it doesn't work.
Dim n As integer
Dim StrSQL As String
Dim mymain As Variant
Dim inputform as string
mymain = Array("well_name", "well_alias", "well_short")
n=0
--try to loop
inputform="form_inputwell"+mymain(n)
StrSQL = "INSERT INTO databasewell (bh_name) VALUES ('" & inputform & "');"
DoCmd.RunSQL StrSQL
n=n+1
--loop end
Any idea to call the value which field inside an array?
for example :
form_inputwell.well_name called by declaring "form_inputwell"+mymain(1)
I found my solution, but thanks anyway for helping.
paramtemp = Forms("form name").Controls(field in form).Value
I think that is what you are trying to do :
Dim n As Integer
Dim StrSQL As String
Dim mymain As Variant
Dim inputform As String
mymain = Array("well_name", "well_alias", "well_short")
For n = LBound(mymain) To UBound(mymain)
inputform = form_inputwell.Controls(mymain(n)).Value
StrSQL = "INSERT INTO databasewell (bh_name) VALUES ('" & inputform & "');"
DoCmd.RunSQL StrSQL
Next n
Related
I have a Sub Procedure that will create a table based on an existing query with 2 text fields (FieldName and SourceName). the value of FieldName will be the name of each field in the existing query, and the value of SourceName will be the name of the table or Query that the field comes from. See the code below. What I am looking to do is to also include the formulas for calculated fields in a 3rd field called FieldFormula. Does anyone know if this is possible? Thank you!
Option Compare Database
Public Sub MapQuery()
Dim strQueryName As String
Dim rst As DAO.Recordset
Dim fld As Field
Dim strSource As String
Dim strField As String
Dim strValue As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim booExists As Boolean
strQueryName = InputBox("Please enter the name of the query that you are looking to map")
Set rst = CurrentDb.OpenRecordset(strQueryName)
intLen = Len(strQueryName)
strnewtablename = Right(strQueryName, intLen - 4)
On Error GoTo error1
booExists = IsObject(CurrentDb.TableDefs(strnewtablename & " Definitions"))
DoCmd.DeleteObject acTable, strnewtablename & " Definitions"
continue:
strSQL1 = "CREATE TABLE [" & strnewtablename & " Definitions]" & " (FieldName CHAR, SourceName CHAR);"
DoCmd.RunSQL (strSQL1)
DoCmd.SetWarnings False
For Each fld In rst.Fields
strField = fld.Name
strSource = fld.SourceTable
Debug.Print strValue
strSQL2 = "INSERT INTO [" & strnewtablename & " Definitions]" & "(FieldName, SourceName) VALUES(""" & strField & """, """ & strSource & """);"
DoCmd.RunSQL (strSQL2)
Next fld
error1:
If Err.Number = 3265 Then
Resume continue
Else
MsgBox Err.Description
End If
DoCmd.SetWarnings True
Exit Sub
DoCmd.SetWarnings True
End Sub
Pulling the expression from a table Calculated field is simple. I did a quick test in the VBA immediate window:
CurrentDb.TableDefs("Teams").Fields("Test").Properties("Expression")
And that returns the expression string. I expect your code will have to do conditional statement that checks if the field is a Calculated type.
However, if you want to pull expression of a calculated field in query, that is very different. There is no "Expression" property as there really is not a field entity. I would say #Andre explained it with 'exist only in the QueryDef.SQL property' as part of the statement string.
In Access 2007 I'm trying to send the results of a query however, I keep receiving the error "Run-time error '3265': Item not found in this collection." The error is coming up on the line:
Set qry = CurrentDb.QueryDefs(ReportQueryName)
I've checked spelling on the fields and I've tried messing with the Tools>References to make sure that I have the correct library.
This is my current code:
Private Sub Command202_Click()
Dim qry As DAO.QueryDef
Dim strSQL As String
Dim ReportQueryName As String
ReportQueryName = "ReportEmail"
Set qry = CurrentDb.QueryDefs(ReportQueryName)
strSQL = "SELECT [ID], [title] FROM Cases WHERE ID = " & Me.ID
qry.SQL = strSQL
DoCmd.SendObject acSendQuery, "ReportEmail", acFormatXLSX, "email#address.com", ..., , False
End Sub
You can't use QueryDefs to create a new query - you have to use CreateQueryDef instead:
Private Sub Command202_Click()
Dim qry As DAO.QueryDef
Dim strSQL As String
Dim ReportQueryName As String
ReportQueryName = "ReportEmail"
strSQL = "SELECT [ID], [title] FROM Cases WHERE ID = " & Me.ID
Set qry = CurrentDb.CreateQueryDef(ReportQueryName,strSQL)
DoCmd.SendObject acSendQuery, "ReportEmail", acFormatXLSX, _
"email#address.com", ..., , False
End Sub
Sometimes your new query will not show up in the Access windows straight away.
If you want it to, you can use:
Application.RefreshDatabaseWindow
I want to write all the records in a query to an e-mail.
This writes the first record in the query.
MyBodyText = MailList("AccountName") & " - " & MailList("ExpirationDate")
I know I need some kind of loop.
MailList is defined as follows
Set MailList = db.OpenRecordset("qryDateEmail")
Option Compare Database
Option Explicit
Public Function ExpirationDate()
Dim strSQL
Dim db As DAO.Database
Dim MailList As DAO.Recordset
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim Subjectline As String
Dim BodyFile As String
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim MyBodyText As String
Dim MyDecision As String
Dim strReportName As String
Dim strEnroll As String
Dim strWho As String
Dim strEmail As String
Set fso = New FileSystemObject
Set MyOutlook = New Outlook.Application
Set db = CurrentDb()
Set MailList = db.OpenRecordset("qryDateEmail")
Subjectline$ = "Expiration Date" & " " & Date
Set MyMail = MyOutlook.CreateItem(olMailItem)
Do While Not MailList.EOF
MyBodyText = MailList("AccountName") & " - " & MailList("ExpirationDate")
MailList.MoveNext
Loop
MyMail.To = "" & ""
MyMail.CC = CurrentUser() & ""
MyMail.Subject = Subjectline$
MyMail.Body = MyBodyText
MyMail.Display
strEmail = Now()
strWho = CurrentUser()
Set MyMail = Nothing
Set MyOutlook = Nothing
End Function
You could loop through the recordset, adding those values from each row to your body text.
Untested air code:
With MailList
Do While Not .EOF
MyBodyText = MyBodyText & !AccountName & _
" - " & !ExpirationDate & vbCrLf
.MoveNext
Loop
End With
Now I see you've added similar code to your question. The problem is that code overwrites the value of MyBodyText each time through the loop. Append to MyBodyText each time instead of replacing the text ...
MyBodyText = MyBodyText & "new text"
instead of ...
MyBodyText = "new text"
The following code runs as far as the marked line. Word then shows a file locked for editing/ open read only prompt. I need to be able to edit the document (that is the whole point of the code).
Sorry for incredibly long code block - I felt it was important to show everything so that it was easier to find the problem.
The code is also kind of clunky with the multiple recordsets, if anyone has any better ideas would love to here them.
Option Explicit
Option Compare Database
Sub InputSafetyData()
Dim dbCur As Database
Dim appCur As Word.Application
Dim docCur As Word.Document
Dim dlgCur As FileDialog
Dim rngCcCur As Range
Dim varDlgCur As Variant
Dim strDocName As String
Dim strDocPath As String
Dim strSQL As String
Dim rsIt As DAO.Recordset
Dim rsHc As DAO.Recordset
Dim rsHz As DAO.Recordset
Dim rsPr As DAO.Recordset
Dim strHc As String
Dim strHz As String
Dim strPr As String
Set dbCur = CurrentDb()
Set dlgCur = Application.FileDialog(msoFileDialogFolderPicker)
With dlgCur
.AllowMultiSelect = False
If .Show <> -1 Then End
varDlgCur = .SelectedItems(1)
End With
strDocPath = CStr(varDlgCur) & "\"
strDocName = Dir(strDocPath & "*.docx")
Set appCur = New Word.Application
appCur.Visible = True
Set dlgCur = Nothing
Do While strDocName <> ""
'Runs as far here
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, ReadOnly:=False, Visible:=False)
If docCur.ReadOnly = False Then
Set rngCcCur = docCur.ContentControls(6).Range
rngCcCur = ""
appCur.ActiveDocument.Tables.Add Range:=rngCcCur, NumRows:=1, NumColumns:=4
With rngCcCur.Tables(0)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
.Style = "Light Shading"
.AutoFitBehavior wdAutoFitWindow
.Cell(1, 1).Range.InsertAfter "Item"
.Cell(1, 2).Range.InsertAfter "Hazcard"
.Cell(1, 3).Range.InsertAfter "Hazard"
.Cell(1, 4).Range.InsertAfter "Precaution"
'select distinct item based on filename
strSQL = "Select Distinct Item From IHR where filename is"
strSQL = strSQL & strDocName
Set rsIt = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsIt.BOF And rsIt.EOF) = True Then
While Not rsIt.EOF
.Rows.Add
.Cell(rsIt.AbsolutePosition + 2, 1).Range.InsertAfter rsIt.Fields(1).Value
'select distinct hazcard based on item
strSQL = "Select Distinct Hazcard From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsHc = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsHc.BOF And rsHc.EOF) = True Then
While Not rsHc.EOF
strHc = strHc & " " & rsHc.Fields(2).Value
.Cell(rsIt.AbsolutePosition + 2, 2).Range.InsertAfter strHc
rsHc.MoveNext
Wend
End If
rsHc.Close
Set rsHc = Nothing
'select distinct hazard based on item
strSQL = "Select Distinct Hazard From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsHz = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsHz.BOF And rsHz.EOF) = True Then
While Not rsHz.EOF
strHc = strHz & " " & rsHz.Fields(2).Value
.Cell(rsIt.AbsolutePosition + 2, 3).Range.InsertAfter strHz
rsHz.MoveNext
Wend
End If
rsHz.Close
Set rsHz = Nothing
'select distinct precaution based on item
strSQL = "Select Distinct Precaution From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsPr = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsPr.BOF And rsPr.EOF) = True Then
While Not rsPr.EOF
strPr = strPr & " " & rsPr.Fields(4).Value
.Cell(rsIt.AbsolutePosition + 2, 4).Range.InsertAfter strPr
rsPr.MoveNext
Wend
End If
rsPr.Close
Set rsPr = Nothing
rsIt.MoveNext
Wend
End If
End With
rsIt.Close
Set rsIt = Nothing
Debug.Print (docCur.Name)
docCur.Save
End If
docCur.Close
Set docCur = Nothing
strDocName = Dir
Loop
Set appCur = Nothing
End Sub
Focus on the immediate problem --- "Cannot open word file for editing".
I created a folder, C:\share\testdocs\, and added Word documents. The code sample below uses a constant for the folder name. I wanted a simple test, so got rid of FileDialog. I also discarded all the recordset code.
I used Visible:=True when opening the Word documents. I didn't understand why you have the Word application visible, but the individual documents not visible. Whatever the logic for that, I chose to make them visible so I could observe the content changes.
I tested this with Access 2007, and it works without errors. If it doesn't work for you, double-check the file system permissions for the current user for both the folder and the target documents.
Public Sub EditWordDocs()
Const cstrFolder As String = "C:\share\testdocs\"
Dim appCur As Word.Application
Dim docCur As Word.Document
Dim strDocName As String
Dim strDocPath As String
Dim strMsg As String
On Error GoTo ErrorHandler
strDocPath = cstrFolder
strDocName = Dir(strDocPath & "*.docx")
Set appCur = New Word.Application
appCur.Visible = True
Do While strDocName <> ""
Debug.Print "strDocName: " & strDocName
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
ReadOnly:=False, Visible:=True)
Debug.Print "FullName: " & docCur.FullName
Debug.Print "ReadOnly: " & docCur.ReadOnly
' add text to the document ... '
docCur.content = docCur.content & vbCrLf & CStr(Now)
docCur.Close SaveChanges:=wdSaveChanges
Set docCur = Nothing
strDocName = Dir
Loop
ExitHere:
On Error Resume Next
appCur.Quit SaveChanges:=wdDoNotSaveChanges
Set appCur = Nothing
On Error GoTo 0
Exit Sub
ErrorHandler:
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure EditWordDocs"
MsgBox strMsg
Debug.Print strMsg
GoTo ExitHere
End Sub
Assuming you're able to get past the read-only problem, I think you have more challenges ahead. Your SELECT statements look highly suspicious to me ...
'select distinct item based on filename '
strSQL = "Select Distinct Item From IHR where filename is"
strSQL = strSQL & strDocName
For example, if strDocName contains "temp.docx", strSQL will contain this text ...
Select Distinct Item From IHR where filename istemp.docx
That is not a valid SELECT statement. I think you may need something more like this ...
SELECT DISTINCT [Item] FROM IHR WHERE filename = 'temp.docx'
Item is a reserved word, so I enclosed it in square brackets to avoid confusing the db engine. Use the equality operator (=) instead of "is" for your string comparisons.
It is extremely useful to Debug.Print your strSQL string, so that you may directly examine the completed statement you're asking the db engine to run ... view it instead of relying on your imagination to guess what it looks like. And when it fails, you can copy the Debug.Print output from the Immediate window and paste it into SQL View of a new query for testing.
However, those Access query issues don't matter until you can get past the read-only issue with your Word documents.
To follow up on the issue of visibility vs. read-only, my code opened the Word documents and modified them without throwing errors when I included either or both of these two changes:
appCur.Visible = False
and
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
ReadOnly:=False, Visible:=False)
I had the same problem with a file opened read only. You can try putting in the following code:
appcur.ActiveWindow.View.ReadingLayout = False
I have a table in Access 2003 that has the following fields
Ptr_RateTable
MinOfWeight_Up_To
Adder
I need to find the unique values for MinOfWeight_Up_To for any table, without showing the table names in my results. I am trying to condense tables sizes in the mainframe by finding tables that can be condensed at the same weight breaks.
So for example
Ptr_RateTable|MinOfWeight_Up_To
1109LW020|1.00
1109LW020|2.00
1109LW020|6.00
1109LW020|11.00
1109LW020|101.00
1109LW020|128.00
1109LW020|129.00
1109LW021|1.00
1109LW021|2.00
1109LW021|3.00
1109LW021|11.00
1109LW021|36.00
1109LW021|41.00
1109LW021|151.00
I would like to see the following as a result and not make another "Profile" with the same weight breaks
Profile1|1.00|2.00|6.00|11.00|101.00|128.00|129.00
Profile2|1.00|2.00|3.00|11.00|36.00|41.00|151.00
First, you need a function that produces a signature for that table. Something akin to:
Public Function GetSignature(sTableName As String) As String
Dim oDB As DAO.Database
Dim oRS As DAO.Recordset
Dim sSQL As String
Dim sResult As String
sSQL = "Select Distinct MinOfWeight_Up_To" _
& vbCrLf & "From [" & sTableName & "]"
& vbCrLf & "Order By MinOfWeight_Up_To"
Set oDB = DBEngine.Workspaces(0).Databases(0)
Set oRS = oDB.OpenRecordset(sSQL, dbOpenForwardOnly, dbReadOnly)
Do Until oRS.EOF
sResult = sResult & "|" & Nz(oRS(0))
oRS.MoveNext
Loop
GetSignature = result
Set oRS = Nothing
Set oDB = Nothing
End Function
Once you have that, you would need another routine that assembles a list of the tables, calls the above signature for each table and stores the result in a temporary table. You would then query that temporary table for the unique list of signatures.
It should be noted that gazillions of string concatenations will be very slow. Instead you should look for implementations of a more efficient string builder class that you can use to build the signatures.
Using a crosstab query:
Dim rs As New ADODB.Recordset
Dim cn As New ADODB.Connection
Set cn = CurrentProject.Connection
sSQL = "TRANSFORM Min(s.MinOfWeight_Up_To) AS Min_Weight " _
& "SELECT 'Profile' & Right([Ptr_RateTable],2) AS Profile " _
& "FROM Sample s " _
& "GROUP BY s.Ptr_RateTable " _
& "PIVOT s.MinOfWeight_Up_To"
rs.Open sSQL, cn
astr = rs.GetString
Do While InStr(astr, Chr(9) & Chr(9)) > 0
astr = Replace(astr, Chr(9) & Chr(9), Chr(9))
Loop
Debug.Print astr