I'm trying to create a disconnected recordset with ADO including a Memo field (adLongVarWChar).
For some reason it gets converted back to adVarWChar.
What am I doing wrong?
Private Sub Form_Load()
Dim rs As New Recordset
rs.Fields.Append "test", adLongVarWChar, 512, adFldIsNullable Or adFldLong Or adFldMayBeNull Or adFldMayDefer Or adFldUnknownUpdatable
Debug.Print rs.Fields(0).Type & " <- This should be 203 (adLongVarWChar) but it returns 202 (adVarWChar)"
Unload Me
End Sub
As it turns out, for some reason, you need to first add a record, then the DataType returns correctly:
Private Sub Form_Load()
Dim rs As New Recordset
rs.Fields.Append "test", adLongVarWChar, &H7FFFFFFF, adFldIsNullable Or adFldLong Or adFldMayBeNull Or adFldMayDefer Or adFldUnknownUpdatable
Debug.Print rs.Fields(0).Type & " <- This should be 203 (adLongVarWChar) but it returns 202 (adVarWChar)"
rs.Open
rs.AddNew
rs.Update
Debug.Print rs.Fields(0).Type & " <- This is now 203 (adLongVarWChar)"
Unload Me
End Sub
Related
when i run the given original code the error in below line is shown "Run-time error 91"
con.Open "Provider=Microsoft.Jet.4.0;Data Source=C:\Documents and Settings\XPMUser\Desktop\New Folder\prac1.mdb; Persist Security Info = False"
original code
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Private Sub SUBMIT_Click()
con.Open "Provider=Microsoft.Jet.4.0;Data Source=C:\Documents and Settings\XPMUser\Desktop\New Folder\prac1.mdb; Persist Security Info = False"
rs.Open "select DBTB1 from prac1", con, adOpenDynamic, adLockPessimistic
rs.Fields("NUMBER").Value = Text1.Text
rs.Fields("NAME").Value = Text2.Text
rs.Fields("CITY").Value = Text3.Text
MsgBox "data saved!", vbInformation
rs.Update
End Sub
You are getting the Error 91 because you have not actually created the Connection object. Further, you will get the same error with the RecordSet. I have updated your code to allow it to work:
Private Sub SUBMIT_Click()
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.Jet.4.0;Data Source=C:\Documents and Settings\XPMUser\Desktop\New Folder\prac1.mdb; Persist Security Info = False"
Set rs = New ADODB.Recordset
rs.Open "select DBTB1 from prac1", con, adOpenDynamic, adLockPessimistic
rs.AddNew
rs.fields("NUMBER").value = Text1.Text
rs.fields("NAME").value = Text2.Text
rs.fields("CITY").value = Text3.Text
rs.Update
MsgBox "data saved!", vbInformation
End Sub
Also, please note the addition of AddNew prior to updating the database.
I have a table name 'product', and product_name, category as a fields. I want to add the product_name row value to the combobox where the category value is repeated....
product_name | category
--------------+----------
Ceiling fan | fan
Table fan | fan
Wall fan | fan
I try the following code but without do while statement it gives one value and when i am trying to loop it the machine hangs. Plz help
Option explicit
Private sub cboCategories_Click()
cboProducts.clear
rs.open "select * from product". cn, adOpenDynamic. adLockOptimistic
With rs
.find "category=' " & cbiCategories.Text & " ' "
.moveFirst
With rs(0).value
Do until rs.EOF
cboProducts.AddItem rs(0).Value
rs.MoveNext
Loop
End with
End with
End sub
This is my table at present. I want to get the product_name field value to the combobox where the category name is the same, such as 'fan'
There are several ways to skin such a cat. One is to source your ComboBox data from a disconnected hierarchical Recordset created using the Data Shaping Service.
This example assumes a CSV file with a header row, but the same thing works with a Jet or other database table:
Option Explicit
Private rsShapedProducts As ADODB.Recordset
Private Sub cboCategories_Click()
With cboProducts
.Clear
With rsShapedProducts
.MoveFirst
.Find "[Category]='" & cboCategories.List(cboCategories.ListIndex) & "'"
With ![Products].Value
.MoveFirst
Do Until .EOF
cboProducts.AddItem ![Product].Value
.MoveNext
Loop
End With
End With
.ListIndex = 0
End With
End Sub
Private Sub cboProducts_Click()
lblSelection.Caption = cboCategories.List(cboCategories.ListIndex) _
& " -> " _
& cboProducts.List(cboProducts.ListIndex)
End Sub
Private Sub Form_Load()
Set rsShapedProducts = New ADODB.Recordset
With rsShapedProducts
.CursorLocation = adUseClient
.Open "SHAPE {" _
& "SELECT [Category], [Product] FROM [products.txt] " _
& "ORDER BY [Category], [Product]" _
& "} AS [Products] COMPUTE [Products] BY [Category]", _
"Provider=MSDataShape;Data Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source='" & App.Path & "';Extended Properties='Text;Hdr=Yes'", _
adOpenStatic, _
adLockReadOnly, _
adCmdText
Set .ActiveConnection = Nothing
Do Until .EOF
cboCategories.AddItem ![Category].Value
.MoveNext
Loop
End With
Show
cboCategories.ListIndex = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
rsShapedProducts.Close
End Sub
Test data I used:
Category,Product
Fan,Ceiling Fan
Fan,Table Fan
Fan,Wall Fan
Lamp,Floor Lamp
Lamp,Table lamp
Lamp,Desk Lamp
Table,Coffee Table
Table,End Table
Table,Kitchen Table
Table,Dining Table
Table,Card Table
Private Function IsInCollection(ByVal Coll As Collection, CollKey As String) As Boolean
On Error GoTo errHandler
Dim b As Variant
b = Coll(CollKey)
IsInCollection = True
errHandler:
Err.Clear
Exit Function
End Function
Public Sub FillCombo()
Dim rs As Adodb.Recordset
Dim Coll As New Collection
Dim strNewValue As String
Set rs = fillMyRs
Do While Not rs.EOF
strNewValue = rs.Fields("category").Value
If IsInCollection(Coll, strNewValue) Then
strNewValue = strNewValue & " - " & rs.Fields("product_name").Value
Else
Coll.Add strNewValue, strNewValue
End If
Combo1.AddItem strNewValue
rs.MoveNext
Loop
End Sub
I'm using vb6 and sql server.in which on the form load I'm filling 4 combobox.But its taking 10 to 12 minutes to load the form.
My code is as follows:
Can anybody help me to make the form load fast?
Public Sub fillCombo(Id As String, Name As String, Table As String, obj As Object, Optional cond As String)
Dim rsF As New ADODB.Recordset
With rsF
If .State = adStateOpen Then .Close
If cond = "" Then
.Open "Select " & Id & "," & Name & " From " & Table & " Order by " & Name, Cn, adOpenKeyset, adLockOptimistic
Else
.Open "Select " & Id & "," & Name & " From " & Table & " Where " & cond & " Order by " & Name, Cn, adOpenKeyset, adLockOptimistic
End If
obj.Clear
'obj.AddItem ""
While Not .EOF
obj.AddItem .Fields(1)
obj.ItemData(obj.NewIndex) = .Fields(0)
.MoveNext
Wend
.Close
End With
End Sub
function call is as follows:
fillCombo "JobId", "JobName", "Jobs", cboJob
The problem (I believe) is that you are using a server-side recordset. When you do this, you are making one round trip to the server for each iteration of your loop, which is, as you have found, glacially slow.
The solution is to create a client-side recordset. That sends the data from the server to the client in one go. Keep in mind that client-side recordsets are always static; if you set the CursorType to adOpenKeyset the CursorLocation to adUseClient, the latter will override the former and your CursorType will still be adOpenStatic.
Here's a mod to your code, with various improvements (in particular, with your atrocious indenting corrected; you might consider being a bit nicer to the poor folks who have to work with your code down the line when you write it):
Public Sub fillCombo(Id As String, Name As String, Table As String, obj As Object, Optional cond As String)
Dim sql As String
Dim rsF As ADODB.Recordset 'Don't use "As New" in VB6, it's slow
'sql variable with ternary conditional (IIf) is cleaner way to do what you want
sql = "Select " & Id & "," & Name & " From " & Table & IIf(cond = "", "", " Where " & cond) & " Order by " & Name
Set rsF = New ADODB.Recordset
With rsF
.CursorLocation = adUseClient 'Client-side, static cursor
'If .State = adStateOpen Then .Close --Get rid of this: if you just created rsF, it can't be open, so this is a waste of processor cycles
.Open sql, Cn 'Much prettier, yes? :)
obj.Clear 'All this is fine
Do Until .EOF
obj.AddItem .Fields(1)
obj.ItemData(obj.NewIndex) = .Fields(0)
.MoveNext
Loop
.Close
End With
End Sub
This is a continuation of my last post: How to read weight from scale using ethernet connection
After creating the TCP connection in vb10 - I am now trying to read the weight from the scale in iFix (vb6). The code below works if I create a breakpoint and step through: strdata takes the weight of the scale (51g at the moment). However, when i simply run the code, I get the error:
Invalid operation at current state 40020.
What i think is happening is something to do with how quickly it reads or trying to read multiple times. Any tips would be great.
TCPclient is referring to winsock, and frmclient refers to my form. The command "S" is the necessary command for the scale to grab the weight value. Thanks!
Public Sub test()
On Error GoTo errHandler
Dim strData As String
frmClient.tcpClient.LocalPort = 0
frmClient.tcpClient.Connect "192.168.0.1", 8000
'Dim i As Integer
' For i = 0 To 2000
' Debug.Print "connection status=" & frmClient.tcpClient.State
' If frmClient.tcpClient.State = 7 Then
' Exit For Next i
frmClient.tcpClient.SendData "S" & vbCrLf
frmClient.tcpClient.GetData strData
MsgBox ("weight =" & strData)
'Exit Sub
errHandler:
MsgBox Err.Description & " " & Err.Number
'Resume Next
End Sub
Use the DataArrival event of your Winsock Control.
So something like:
' ... in your "frmClient" Form ...
Private Sub tcpClient_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
tcpClient.GetData strData, vbString
MsgBox ("weight =" & strData)
End Sub
*Obviously removing the GetData() call in your original test() method.
Got it working! The code is below. I created a picture sub to initialize the ports/IP at the beginning of the code execution and then to close the connection at the end. I made a timer to automatically read the weight upon stabilization, so the weight can be found by clicking the button, or simply waiting 2 seconds (2000ms). Best of luck and thanks for the help!
Public tcpC As New Winsock
Private Sub CFixPicture_Close()
tcpC.Close
End Sub
Private Sub CFixPicture_Initialize()
tcpC.LocalPort = 0
tcpC.Connect "192.168.0.1", 8000
End Sub
Private Sub CommandButton1_Click()
On Error GoTo errHandler
Dim strData As String
tcpC.SendData "S" & vbCrLf
tcpC.GetData strData
Text4.Caption = "Weight: " & strData
Exit Sub
errHandler:
MsgBox "error:" & Err.Description
End Sub
Private Sub readScale_OnTimeOut(ByVal lTimerId As Long)
Dim strData As String
tcpC.SendData "S" & vbCrLf
tcpC.GetData strData
Text4.Caption = "Weight: " & strData
Exit Sub
End Sub
I am having an odd issue where I am trying to pass three recordsets to a method to have them filled with data all under the same database connection. By reviewing the custom logging info when running the code below I can see that I am getting a Type Mismatch error when assigning the recordsets passed to the method to the local variables within the method.
So the following gets logged when the mthod is called:
7/15/2010 10:59:47 AM - Begin GetALLRecordSets
7/15/2010 10:59:47 AM - Begin GetALLRecordSets RS initialization
The odd bit is that this same code works on our beta server where the asp code is identical and the component dll is identical.
Any thoughts on what may be causing this issue?
Classic ASP code:
set rs1= createobject("ADODB.Recordset")
set rs2 =createobject("ADODB.Recordset")
set rs3 = createobject("ADODB.Recordset")
set myObj = Server.CreateObject("Component.className")
call myObj.GetAllRecordSets(rs1, rs2, rs3)
VB6 Component Code:
Public Sub GetALLRecordSets(ByRef rs1 As Variant, _
ByRef rs2 As Variant, _
ByRef rs3 As Variant)
On Error GoTo ErrorSpot
WriteToLog "Begin GetALLRecordSets", "", 0, ""
Dim lngErrNum As Long
Dim strErrDesc As String
Dim filterStr As String
Dim objConn As ADODB.Connection
Dim myrs1 As ADODB.Recordset
Dim myrs2 As ADODB.Recordset
Dim myrs3 As ADODB.Recordset
WriteToLog "Begin GetALLRecordSets RS initialization", "", 0, ""
Set myrs1 = rs1
Set myrs2 = rs2
Set myrs3 = rs3
WriteToLog "End GetALLRecordSets RS initialization", "", 0, ""
Set rs1 = myrs1.Clone
Set rs2 = myrs2.Clone
Set rs3 = myrs3.Clone
ExitSpot:
'Cleanup
Exit Sub
ErrorSpot:
'Save the error information
lngErrNum = Err.Number
strErrDesc = Err.Description
'Log the error
WriteToLog "GetALLRecordSets", strErrDesc, lngErrNum, strErrDesc
End Sub
Different version of MDAC on server? You may need to create a specific version of Recordset e.g.
Set rs1 = CreateObject("ADODB.Recordset.2.8")