I have a select distinct query that works find on selected fields from a listbox. However I would like it to be a count distinct and I can't seem to get the code right. Below is my working code for select distinct. Thanks in advance for any assistance I've searched for count distinct questions but I don't see any specific to listbox selections.
Private Sub CmdDistinctVal_Click()
Dim cn1 As ADODB.Connection
Dim rs1 As New ADODB.Recordset
Dim cmd1 As New ADODB.Command
Dim varItem As Variant
Dim aFields() As aArray
Dim NumRows As Integer
Dim NumFields As Integer
Dim colcount As Integer
Dim colwidths As String
Dim strRow As String
Dim cnt1 As Integer
Dim cnt2 As Integer
'On Error GoTo Err_ CmdDistinctVal_Click
'cmd1.ActiveConnection = CurrentProject.Connection
Me.DistinctResultsFldVal.RowSource = ""
ReDim aFields(50)
For cnt1 = 1 To 50
ReDim aFields(cnt1).fValue(6000)
Next
NumRows = 0
colcount = 0
For Each varItem In Me!ResultsFieldList.ItemsSelected
colcount = colcount + 1
aFields(colcount).fName = Me!ResultsFieldList.ItemData(varItem)
NumFields = 0
rs1.Open "SELECT DISTINCT " & Me!ResultsFieldList.ItemData(varItem) & "
FROM [Results Report]", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If rs1.RecordCount > NumRows Then NumRows = rs1.RecordCount
strRow = strRow & Me!ResultsFieldList.ItemData(varItem) & ";"
While Not rs1.EOF
NumFields = NumFields + 1
If NumFields > NumRows Then
NumRows = NumFields
End If
aFields(colcount).fValue(NumFields) = rs1(0) & ""
rs1.MoveNext
Wend
rs1.Close
Next varItem
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.ColumnCount = colcount
Me.DistinctResultsFldVal.ColumnWidths = Mid(colwidths, 2)
Me.DistinctResultsFldVal.AddItem (strRow)
For cnt1 = 1 To NumRows
strRow = ""
For cnt2 = 1 To colcount
If aFields(cnt2).fValue(cnt1) = "" Then
strRow = strRow & ";"
Else
strRow = strRow & aFields(cnt2).fValue(cnt1) & ";"
End If
Next
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.AddItem (strRow)
Next
'Err_ CmdDistinctVal_Click:
'MsgBox "All null values were found in one or more of your selected fields"
End Sub
Related
In LibreOffice is it possible to get bookmark that is inserted in the text?
With the code below I can get the list of all the bookmarks I have available, but I just wanted the ones that are actually inserted in the text.
XBookmarksSupplier xBookmarksSupplier =
UnoRuntime.queryInterface(XBookmarksSupplier.class,
xCurrentComponent); XNameAccess xNamedBookmarks =
xBookmarksSupplier.getBookmarks();
Hope this helps:
Sub MyBookmarks
Dim oBookmarks As Variant
Dim oElementNames As Variant
Dim oBookmark As Variant
Dim oTextFields As Variant
Dim oEnum As Variant
Dim oTextField As Variant
Dim sSourceName As String
Dim i As Long, j As Long
Dim sResult As String
Rem First step - collect Bookmarks
oBookmarks = ThisComponent.getBookmarks()
oElementNames = oBookmarks.getElementNames()
Rem Create list of Bookmarks to count Text Fields with it
ReDim oBookmark(LBound(oElementNames) To UBound(oElementNames))
For i = LBound(oElementNames) To UBound(oElementNames)
oBookmark(i) = Array(oElementNames(i),0)
Next i
Rem Enumerate Text Fields
oTextFields = ThisComponent.getTextFields()
oEnum = oTextFields.createEnumeration()
Do While oEnum.hasMoreElements()
oTextField = oEnum.nextElement()
sSourceName = oTextField.SourceName
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(0) = sSourceName Then
oBookmark(i)(1) = oBookmark(i)(1) + 1
Exit For
EndIf
Next i
Loop
Rem Show results
sResult = ""
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(1) > 0 Then
sResult = sResult + oBookmark(i)(0) + " (" + oBookmark(i)(1) + ")" + Chr(10)
EndIf
Next i
If Len(sResult) > 0 Then
sResult = Left(sResult, Len(sResult)-1)
MsgBox("The text of the document uses Bookmarks:" + Chr(10) + sResult, MB_ICONINFORMATION, "Used Bookmarks")
Else
MsgBox("No Bookmarks are used in the text of the document", MB_ICONEXCLAMATION, "No Bookmarks")
EndIf
sResult = ""
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(1) = 0 Then
sResult = sResult + oBookmark(i)(0) + ", "
EndIf
Next i
If Len(sResult) > 0 Then
MsgBox("Bookmarks that are not used in the text of the document:" + Chr(10) + Left(sResult, Len(sResult)-2), MB_ICONINFORMATION, "Not Used Bookmarks")
EndIf
End Sub
I'm trying to export one of my queries to email using VBA in a table format. Similar to when you go to external data and click and E-Mail and it adds an attachment to outlook. Except I want it in the body. I put the following code in a button.
I found and made some changes to some code. This is what I have.
Private Sub Command5_Click()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 4) As String
Dim aRow(1 To 4) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Part"
aHead(2) = "Description"
aHead(3) = "Qty"
aHead(4) = "Price"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th> <th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From qry_email"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("Part")
aRow(2) = rec("Description")
aRow(3) = rec("Qty")
aRow(4) = rec("Price")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.Display
olItem.To = "email#email.com"
olItem.Subject = "Test E-mail"
olItem.HTMLBody = Join(aBody, vbNewLine)
olItem.Display
End Sub
When I run the code, I get a "Run-time error '3061' too few parameters. Expected 1."
If i click debug i get this highlighted in yellow. Anybody help would be greatly appreciated!
Edit
I tried a different approach which actually gave me the list in the body of the email. But it does it for the whole table instead of just the one record I want. This is what the SQL looks like of the query.
SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price
FROM tblePMParts
WHERE (((tblePMParts.WOID)=[Forms]![fmremail]![Text1]));
How would I go about adding the WHERE to the code below.
Private Sub Command4_Click()
'On Error GoTo Errorhandler
Dim olApp As Object
Dim olItem As Variant
Dim olatt As String
Dim olMailTem As Variant
Dim strSendTo As String
Dim strMsg As String
Dim strTo As String
Dim strcc As String
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim qry As DAO.QueryDef
Dim fld As Field
Dim varItem As Variant
Dim strtable As String
Dim rec As DAO.Recordset
Dim strQry As String
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts; "
strSendTo = "test#email.com"
strTo = ""
strcc = ""
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(olMailTem)
olItem.Display
olItem.To = strTo
olItem.CC = strcc
olItem.Body = ""
olItem.Subject = "Please Quote the Following!"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
rec.MoveLast
rec.MoveFirst
intCount = rec.RecordCount
For intLoop = 1 To intCount
olItem.Body = olItem.Body & rec("[Part#]") & " - " & rec("PartDescription") & " - " & rec("Qty") & " - " & rec("Price")
rec.MoveNext
Next intLoop
End If
MsgBox "Completed Export"
Set olApp = Nothing
Set olItem = Nothing
Exit_Command21_Click:
Exit Sub
ErrorHandler:
MsgBox Err.Description, , Err.Number
Resume Exit_Command21_Click
End Sub
I got it working. Here is the code in case anybody needs it.
Private Sub Command5_Click()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 3) As String
Dim aRow(1 To 3) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Part#"
aHead(2) = "Description"
aHead(3) = "Qty"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts " & _
"WHERE (((tblePMParts.WOID)=" & [Forms]![fmremail]![Text1] & "));"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("[Part#]")
aRow(2) = rec("PartDescription")
aRow(3) = rec("Qty")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.Display
olItem.To = "Email"
olItem.Subject = "Test E-mail"
olItem.HTMLBody = Join(aBody, vbNewLine)
olItem.Display
End Sub
Somewhere in your code, put a line that says
X = [Forms]![fmremail]![Text1]
Put a breakpoint in your code (hopefully you know how to do that?) on that line. When the code breaks, press F8 to step to the next line, and then type ?X in the Immediate Window. Or you can just hover your mouse over the line with the break point. The point is, you need to see what your code thinks [Forms]![fmremail]![Text1] is equal to. If it's null, you have a problem with your reference. In that case, you may need to add ".Value" or ".Text" to the end of it.
Another thing to check is your datatype for WOID. if it's text, you need to surround it with single quotes.
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts " & _
"WHERE (((tblePMParts.WOID)='" & [Forms]![fmremail]![Text1] & "'));"
As the code below, I need to create a dynamic table in which each cell gets validated. If there is any wrong input, error message will pop up for that specific cell. Now our BA doesn’t want to display multiple error messages for each column. Only simply display one error message for each column like last name like “Last Name is invalid” no matter how many last names are invalid. How can I accomplish this? Is that possible?
Thanks in advance. I will really appreciate your response.
Thanks,
Dev2016
Protected Sub ShowBoxes(ByVal startRow As Integer, ByVal nRowsAdd As Integer)
Dim d As Integer = 10
For d = startRow To (startRow + nRowsAdd - 1)
Dim row As New HtmlTableRow()
row.VAlign = "center"
row.Attributes("class") = "bgA"
row.ID = "IndivRow_" & d.ToString
Dim col1 As New HtmlTableCell()
col1.Align = "center"
col1.Width = 29
col1.InnerHtml = (d + 1).ToString
Dim col2 As New HtmlTableCell()
col2.Width = 53
col2.VAlign = "left"
Dim txt2 As New TextBox()
txt2.ID = "Last_" & d.ToString
txt2.Columns = "29"
txt2.MaxLength = "30"
Dim reg2 As New RegularExpressionValidator()
reg2.ID = "regLast_" & d.ToString
reg2.ControlToValidate = "Last_" & d.ToString
reg2.ValidationExpression = "^[a-zA-Z0-9""()-. '\s]{1,50}$"
reg2.ErrorMessage = "Last Name on line " & (d + 1).ToString & " contains invalid characters."
reg2.Text = "*"
reg2.Display = ValidatorDisplay.Static
reg2.ValidationGroup = "SubmitFormClient"
reg2.SetFocusOnError = True
col2.Controls.Add(txt2)
col2.Controls.Add(reg2)
Dim col3 As New HtmlTableCell()
col3.Width = 53
col3.VAlign = "left"
Dim txt3 As New TextBox()
txt3.ID = "First_" & d.ToString
txt3.MaxLength = "30"
Dim reg3 As New RegularExpressionValidator()
reg3.ID = "regFirst_" & d.ToString
reg3.ControlToValidate = "First_" & d.ToString
reg3.ValidationExpression = "^[a-zA-Z0-9""()-. '\s]{1,50}$"
reg3.ErrorMessage = "First Name on line " & (d + 1).ToString & " contains invalid characters."
reg3.Text = "*"
reg3.Display = ValidatorDisplay.Static
reg3.ValidationGroup = "SubmitFormClient"
reg3.SetFocusOnError = True
col3.Controls.Add(txt3)
col3.controls.add(reg3)
row.Cells.Add(col1)
row.Cells.Add(col2)
row.Cells.Add(col3)
tableIndiv.Rows.Add(row)
Next d
End Sub
I have a DevExpress XtraChart object with several series, all of type: line.
I have a requirement from a client to align the series by the max value of each series. This is without regard to the attached axis, has anyone done this before?
Although I was interested in displaying this on the chart element, the 'work' was done on the underlying DataSet.
I was able to achieve this by looping through the series collection, deriving the max value of the first series, through a SQL query, and then each subsequent series, and noting the difference, and then adding or subtracting the difference at the DataSet level.
Here's the code:
Private Sub cbAlignPeaks_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cbAlignPeaks.CheckedChanged
Dim dt As DataTable = chart.DataSource
Dim Row() As Data.DataRow
Dim s As Series = Nothing
Dim dtr As DataTableReader = Nothing
Dim maxTimeGet, maxTimeSet, diff As Decimal
Me.Cursor = Cursors.WaitCursor
If cbAlignPeaksPre.Checked Then
For i As Integer = 0 To chartPreTim.Series.Count - 1
s = chartPreTim.Series(i)
If _offsets.Count = chartPreTim.Series.Count - 1 Then
If i > 0 Then
diff = _offsets(s.DataFilters(0).Value)
Row = dt.Select("BORING_NAME = '" & s.Name & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") + diff
Next
End If
Else
If i = 0 Then 'get adjustment info
dtr = getDetectorMax(s.DataFilters(0).Value, cbDetectors.Text, timType.PRE) ' <-- getDetectorMax runs a SQL query returning the max value
If dtr.Read Then
maxTimeGet = dtr("TIME_SEC")
End If
Else 'set adjustment info
dtr = Nothing
dtr = getDetectorMax(s.DataFilters(0).Value, cbDetectors.Text, timType.PRE)
If dtr.Read Then
maxTimeSet = dtr("TIME_SEC")
End If
If maxTimeGet > maxTimeSet Then
diff = maxTimeGet - maxTimeSet
_offsets.Add(s.DataFilters(0).Value, diff)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") + diff
Next
Else
diff = maxTimeSet - maxTimeGet
_offsets.Add(s.DataFilters(0).Value, diff * -1)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") - diff
Next
End If
End If
End If
Next
Else
For i As Integer = 1 To chartPreTim.Series.Count - 1 ' We skip item 0 as that's the baseline
s = chartPreTim.Series(i)
diff = _offsets(s.DataFilters(0).Value)
Row = dt.Select("BORING_NAME = '" & s.DataFilters(0).Value & "'")
For k As Integer = 0 To Row.Count - 1
Row(k)("TIME_SEC") = Row(k)("TIME_SEC") - diff
Next
Next
End If
chartPreTim.RefreshData()
chartPreTim.Refresh()
Me.Cursor = Cursors.Default
End Sub
i am working on a project which is migrated from vb6 to vb.net.And during working with the crystal reports i got this problem.Actually i have to print the axmschart of my application in reports.So i am using the following code :
gtmpString = Application.StartupPath & gsGraphPicPath
Dim myPic As New Bitmap(_chtAnlysGraph_0.AsBitmap)'''''ERROR here...as bitmap is not a member of AXMSCHART''''''''
PictureBox1.Image = myPic
PictureBox1.Image.Save(gtmpString, System.Drawing.Imaging.ImageFormat.Png)
Dim intCount As Short
Dim dRow As DataRow
Dim dTable As New DataTable
Dim dt As New DataSetResults.AnalysisTableDataTable 'Report filling
dTable = dt.Copy
dRow = dTable.NewRow
For intCount = 1 To msgAnlysData.Rows - 1
dRow = dTable.NewRow
dRow.Item("Sr_No") = msgAnlysData.get_TextMatrix(intCount, 1)
dRow.Item("abs_val") = msgAnlysData.get_TextMatrix(intCount, 2)
dRow.Item("pt_conc") = msgAnlysData.get_TextMatrix(intCount, 3)
dRow.Item("lin_conc") = msgAnlysData.get_TextMatrix(intCount, 4)
dRow.Item("poly_conc") = msgAnlysData.get_TextMatrix(intCount, 5)
'If gtmpString = True Then
gtmpString = Application.StartupPath & gsGraphPicPath
dRow.Item("graph1") = savepic(gtmpString)
' End If
If msgAnlysData.get_TextMatrix(intCount, 2) = Nothing Then
Else
dTable.Rows.Add(dRow)
End If
Next intCount
Help me out here plzz.
Dim myPic As New Bitmap(_chtAnlysGraph_0)