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)
Related
This is the code I have so far:
REM ***** BASIC *****
Option Explicit
rem-----------------------------------------------------------------------
REM----
Sub Main
Dim YearNm As Long, DayCol As Long, DayRow As Long
Dim DataSheet As Object, oSheet As Object
Dim SelDate As Date
Dim oDoc As String, oSelection As String
Set DataSheet = ThisComponent.CurrentController.ActiveSheet
oDoc = ThisComponent
oSelection = ThisComponent.CurrentSelection
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Private Sub Worksheet_Change(ByVal Target As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1))
'If Not Intersect(Target, Dim oSheet as Object[n]oSheet = `
'`ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)("AH6:AH29")) Is Nothing Then
If Not Intersect(Target,Range("AH6:AH29")) Is Nothing Then
'("AH5") = ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ThisComponent.ActiveSheet[n}ThisComponent.CurrentController.Select(oSheet.getCellThisComponent.CurrentController.ThisCompponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet =ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(ByName(ByName($2)).Value))ed Date
'Range("AH5") = ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCell = ThisComponent.CurrentController.ThisComponent.ActiveSheet.CurrentController.Select(oSheet.getCellThisComponent.CurrentController.ThisCompponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(ByName(ByName($2)).Value))as Date)
Range("AH5") = oSelection
'
YearNm = [ScYear]
'Determine if data worksheet exists
On Error Resume Next
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
On Error Goto 0
If DataSheet Is Nothing Then
ThisWorkbook.Sheets.Add(After:=Sheets("Schedule")).Name = YearNm
Set DataSheet = ThisWorkbook.Sheets("" & YearNM & "")
Active
End If
'
DayRow = Tatget.Row 'Row
DayCol = SelDate - DateSerial(YearNm, 1, 1) + 1 'Dtermine Column for Data Sheet
DataSheet.Cells(DayRow, DayCol).Value = Target.Value
End If
End Sub
Private Sub Sheet()
CurrentController.setThisComponent.CurrentController.ActiveSheet(vSheet);ionChange(ByVal Target As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)("B6:AF29")) Is Nothing Then
If IsDate(Target.Value) = False Then Exit Sub
SlDate = Target.Value 'Selected Date
YearNm = [ScYear]
ThisComponent.CurrentControlller.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CcurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(("AH5")).Value = SelDate
'Determine if data worksheet exists
On Error Resume Next
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
On Error Goto 0
If DataSheet Is Nothing Then
'
ThisWorkbook.Sheets.Add(After:=Sheets("Schedule")).Name = YearNm
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
Activate
End If
DayRow = Target.Row 'Row
DayCol = SelDate - DateSerial(YearNm, 1, 1) +1 'Determine Column for Data Sheet
ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.Activesheet[n]oSheet.getCellRangeByName($1)ByName(ByName(("AH6:AH29")).Value = DataSheet.ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet =
ThisComponent.Currentcontroller.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName((DataSheet).getCellByPosition((6,DayCol), DataSheet.Cells(29, DayCol)), $3)).Value
End If
End Sub]
Basically what I need to happen is this: when a new day is selected, the value in cell "AH5" change to the selected date long version, "month day, year".
Thank you in advance.
I am trying to convert visual basic to open office.
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 am trying to insert a piechart in open-office using macro. But the code shows error:
Line:
Dim oDiagram As New com.sun.star.chart.PieDiagram
Error:
"Object not accessible. Invalid reference."
I am unable to figure out why. Kindly help. Here is my complete macro code:
Sub Macro1
Dim oRange as Object
Dim oRangeAddress(1) As New com.sun.star.table.CellRangeAddress
Dim oDiagram As New com.sun.star.chart.PieDiagram
Dim oRect As New com.sun.star.awt.Rectangle
Dim cTitle as String
oRange = thisComponent.getCurrentSelection.getRangeAddress
oSheets = ThisComponent.getSheets()
oSheet = oSheets.getByIndex(0)
oCharts = oSheet.Charts
oRect.Width = 10000
oRect.Height = 10000
oRect.X = 8000
oRect.Y = 1000
oRangeAddress(0).Sheet = oRange.Sheet
oRangeAddress(0).StartColumn = 0
oRangeAddress(0).StartRow = 0
oRangeAddress(0).EndColumn = 1
oRangeAddress(0).EndRow = 2
cTitle = "Test Results"
oCharts.addNewByName(cTitle,oRect,oRangeAddress(),TRUE, TRUE)
oChart = oCharts.getByName(cTitle).embeddedObject
oChart.Diagram = oDiagram
oChart.HasMainTitle = True
oChart.Title.String = cTitle
End Sub
Here is the input sheet data:
You can't instantiate a com.sun.star.chart.PieDiagram directly, independent of an already-existing chart. Instead, you'll have to create the chart first, and then create a PieDiagram. Thus, to make the macro work, do the following:
remove the line Dim oDiagram As New com.sun.star.chart.PieDiagram
change the line oChart.Diagram = oDiagram to oChart.Diagram = oChart.createInstance("com.sun.star.chart.PieDiagram").
This results in the following code (i've tested this with OpenOffice.org Calc 4.1.0 on Win7):
Sub Macro1
Dim oRange as Object
Dim oRangeAddress(1) As New com.sun.star.table.CellRangeAddress
Dim oRect As New com.sun.star.awt.Rectangle
Dim cTitle as String
oRange = thisComponent.getCurrentSelection.getRangeAddress
oSheets = ThisComponent.getSheets()
oSheet = oSheets.getByIndex(0)
oCharts = oSheet.Charts
oRect.Width = 10000
oRect.Height = 10000
oRect.X = 8000
oRect.Y = 1000
oRangeAddress(0).Sheet = oRange.Sheet
oRangeAddress(0).StartColumn = 0
oRangeAddress(0).StartRow = 0
oRangeAddress(0).EndColumn = 1
oRangeAddress(0).EndRow = 2
cTitle = "Test Results"
oCharts.addNewByName(cTitle,oRect,oRangeAddress(),TRUE, TRUE)
oChart = oCharts.getByName(cTitle).embeddedObject
oChart.Diagram = oChart.createInstance("com.sun.star.chart.PieDiagram")
oChart.HasMainTitle = True
oChart.Title.String = cTitle
End Sub
Running the macro should give the following result:
NB: The macro won't run on LibreOffice Calc; it only works with OpenOffice.org Calc. I think this a LibreOffice bug, since i coudn't find any differences in the API of OOo and LO.
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