VB6.0 with DataControl Database Programming - vb6

can you help out access the database... I have been reading some tutorials but I don't know where to start doing this one. I used DataControl to access the database. First, the program will prompt for the ID Number and then Search for the further information and display it in texboxes when Search Employee button clicked. I know how to set the properties of textboxes in order to appear the value of my database to my output without clicking the Search Employee button but I want to click first the button Search Employee. I'm a beginner in VB6. Please help me out! I need this project now.

Ok, I had some time to spare, here you go, first add a reference to Microsoft ActiveX Data Objects 2.X Library:
Form1 Code:
Option Explicit
''Add the following items to your form and name them as indicated:
''Four(4) text boxes - Named: tbIDNumber, tbName, tbAddress, and tbContactName.
''One(1) Command button - Named Command1
Private Sub Command1_Click()
Dim rs As ADODB.Recordset
Dim DB As cDatabase
Dim l As Long
Set rs = New ADODB.Recordset
Set DB = New cDatabase
With DB
.DBCursorType = adOpenForwardOnly
.DBLockType = adLockReadOnly
.DBOptions = adCmdText
.DSNName = "Your_DSN_Name"
.SQLUserID = "Your_SQL_Login_Name"
.SQLPassword = "Your_SQL_Login_Password"
Set rs = .GetRS("Select Name, Address, ContactNumber FROM YourTableName WHERE IDNumber = '" & tbIDNumber.Text & "'")
End With
If rs.RecordCount > 0 Then
tbName.Text = rs(0).Value & ""
tbAddress.Text = rs(1).Value & ""
tbContactName.Text = rs(2).Value & ""
End If
Exit_Sub:
rs.Close
Set rs = Nothing
Set DB = Nothing
End Sub
Add a Class Module Object to your project and name it cDatabase. Then copy the following Code into it:
Option Explicit
Private m_eDBCursorType As ADODB.CursorTypeEnum 'Cursor (Dynamic, Forward Only, Keyset, Static)
Private m_eDBLockType As ADODB.LockTypeEnum 'Locks (BatchOptimistic,Optimistic,Pessimistic, Read Only)
Private m_eDBOptions As ADODB.CommandTypeEnum 'DB Options
Private m_sDSNName As String
Private m_sSQLUserID As String
Private m_sSQLPassword As String
Private cn As ADODB.Connection
Private Sub Class_Initialize()
m_eDBCursorType = adOpenForwardOnly
m_eDBLockType = adLockReadOnly
m_eDBOptions = adCmdText
End Sub
Private Function ConnectionString() As String
ConnectionString = "DSN=" & m_sDSNName & "" & _
";UID=" & m_sSQLUserID & _
";PWD=" & m_sSQLPassword & ";"
''If you are using MS Access as your back end you will need to change the connection string to the following:
''ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
''If you are using a DNS-Less connection to SQL Server, then you will need to change the connection string to the following:
''ConnectionString = "Data Source=myServerAddress;Initial Catalog=myDataBase;User Id=" & m_sSQLUserID & ";Password=" & m_sSQLPassword & ";"
''You can find more Connection Strings at http://connectionstrings.com/
End Function
Private Sub GetCN()
On Error GoTo GetCN_Error
If cn.State = 0 Then
StartCN:
Set cn = New ADODB.Connection
cn.Open ConnectionString
With cn
.CommandTimeout = 0
.CursorLocation = adUseClient
End With
End If
On Error GoTo 0
Exit Sub
GetCN_Error:
If Err.Number = 91 Then
Resume StartCN
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetCN of Module modDatabaseConnections"
End If
End Sub
Public Function GetRS(sSQL As String) As ADODB.Recordset
Dim eRS As ADODB.Recordset
On Error GoTo GetRS_Error
TryAgain:
If Len(Trim(sSQL)) > 0 Then
Call GetCN
Set eRS = New ADODB.Recordset 'Creates record set
eRS.Open sSQL, cn, m_eDBCursorType, m_eDBLockType, m_eDBOptions
Set GetRS = eRS
Else
MsgBox "You have to submit a SQL String"
End If
On Error GoTo 0
Exit Function
GetRS_Error:
If Err.Number = 91 Then
Call GetCN
GoTo TryAgain
ElseIf Err.Number = -2147217900 Then
Exit Function
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetRS of Module" & vbCrLf & vbCrLf & "SQL - " & sSQL
End If
End Function
Public Property Get DBOptions() As ADODB.CommandTypeEnum
DBOptions = m_eDBOptions
End Property
Public Property Let DBOptions(ByVal eDBOptions As ADODB.CommandTypeEnum)
m_eDBOptions = eDBOptions
End Property
Public Property Get DBCursorType() As ADODB.CursorTypeEnum
DBCursorType = m_eDBCursorType
End Property
Public Property Let DBCursorType(ByVal eDBCursorType As ADODB.CursorTypeEnum)
m_eDBCursorType = eDBCursorType
End Property
Public Property Get DBLockType() As ADODB.LockTypeEnum
DBLockType = m_eDBLockType
End Property
Public Property Let DBLockType(ByVal eDBLockType As ADODB.LockTypeEnum)
m_eDBLockType = eDBLockType
End Property
Public Property Get DSNName() As String
DSNName = m_sDSNName
End Property
Public Property Let DSNName(ByVal sDSNName As String)
m_sDSNName = sDSNName
End Property
Public Property Get SQLUserID() As String
SQLUserID = m_sSQLUserID
End Property
Public Property Let SQLUserID(ByVal sSQLUserID As String)
m_sSQLUserID = sSQLUserID
End Property
Public Property Get SQLPassword() As String
SQLPassword = m_sSQLPassword
End Property
Public Property Let SQLPassword(ByVal sSQLPassword As String)
m_sSQLPassword = sSQLPassword
End Property
This should do the trick.

Related

Check for existing DSN before creating it with vb6 code

i have done a connection using DSN, in which i have created a DSN throgh program. In that i have called a function to create a DSN, I dont want to call that function ecerytime i run the software, Instead i want to check whether dsn with the same name is already exist in the system or not, if it is not exist then only call to the function`
Public Sub ConnectDB(Con As ADODB.Connection)
Call CreatSQLDSN("TRDSN", VarSrvNm, VarDbName)
If Cn.State = 1 Then Cn.Close
On Error Resume Next
Con.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=False;User ID=sa;Data Source=TRDSN;Initial Catalog='" & VarDbName & "'"
Con.Open Con.ConnectionString
If Err.Number <> 0 Then
If Err.Number = -2147467259 Then
If MsgBox(ServerName & " Server not Found. Connect to Other Server?", vbQuestion + vbDefaultButton2 + vbYesNo, "") = vbYes Then
PrintFile = Trim(Left(FindWindowPath, 3) & "DosPrint.Bat")
FileSystemObject.CreateTextFile PrintFile, True
Set TextStream = FileSystemObject.OpenTextFile(PrintFile, ForAppending)
TextStream.WriteLine "Del " & Left(FindWindowPath, 3) & "ServerName.dat"
TextStream.Close
Shell PrintFile, vbHide
End If
End
Else
If MsgBox(Err.Description, vbQuestion + vbOKOnly, "") = vbOK Then
Cancel = True
Exit Sub
End If
End If
End If
0
End Sub
Public Function CreatSQLDSN(SqlDsnName As String, SqlServerName As String, SqlDataName As String)
Dim Ret%, Driver$, Attributes$
Driver = "SQL Server" & Chr(0)
Attributes = "Server=" & SqlServerName & Chr(0)
Attributes = Attributes & "DSN=" & SqlDsnName & Chr(0)
Attributes = Attributes & "Database=" & SqlDataName & Chr(0)
Ret = SQLConfigDataSource(vbAPINull, ODBC_Add_User_DSN, Driver, Attributes)
'ret is equal to 1 on success and 0 if there is an error
If Ret <> 1 Then
MsgBox "User DSN Creation Failed"
End If
End Function`
A couple of options come to mind when needing to know if a DSN exists. You could either read through the Registry, or leverage your existing API call. I prefer the second option. It seems like a cleaner way to check for the existence of the DSN. Here is an example of what I am talking about:
Option Explicit
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Private Const ODBC_ADD_DSN = 1
Private Const ODBC_CONFIG_DSN = 2
Private Const ODBC_REMOVE_DSN = 3
Private Const ODBC_ADD_SYS_DSN = 4
Private Const ODBC_CONFIG_SYS_DSN = 5
Private Const ODBC_REMOVE_SYS_DSN = 6
Private Const ODBC_REMOVE_DEFAULT_DSN = 7
Private Sub cmdCreate_Click()
Dim VarSrvNm As String
Dim VarDbName As String
VarSrvNm = "MyServer"
VarDbName = "MyDB"
If Not SQLDSNExists("TRDSN", VarSrvNm, VarDbName) Then
If Not CreateSQLDSN("TRDSN", VarSrvNm, VarDbName) Then
MsgBox "User DSN Creation Failed"
End If
End If
End Sub
Public Function CreateSQLDSN(SqlDsnName As String, SqlServerName As String, SqlDataName As String) As Boolean
Dim Ret%, Driver$, Attributes$
Driver = "SQL Server" & Chr(0)
Attributes = "Server=" & SqlServerName & Chr(0)
Attributes = Attributes & "DSN=" & SqlDsnName & Chr(0)
Attributes = Attributes & "Database=" & SqlDataName & Chr(0)
Ret = SQLConfigDataSource(0&, ODBC_ADD_DSN, Driver, Attributes)
'ret is equal to 1 on success and 0 if there is an error
CreateSQLDSN = (Ret = 1)
End Function
Public Function SQLDSNExists(SqlDsnName As String, SqlServerName As String, SqlDataName As String) As Boolean
Dim Ret%, Driver$, Attributes$
Driver = "SQL Server" & Chr(0)
Attributes = "Server=" & SqlServerName & Chr(0)
Attributes = Attributes & "DSN=" & SqlDsnName & Chr(0)
Attributes = Attributes & "Database=" & SqlDataName & Chr(0)
Ret = SQLConfigDataSource(0&, ODBC_CONFIG_DSN, Driver, Attributes)
'ret is equal to 1 on success and 0 if there is an error
SQLDSNExists = (Ret = 1)
End Function
The main idea here is to try to modify the DSN you want to add. If the call fails, then the DSN does not exist.

How to use class initialize vb6 to connect to SQL server?

Anyone can help me how can I do for that variable objusername and objpassword of sub login are recognized by the sub Class_Initialize ? I tried this but it does not work.
private cn as ADODB.Connection
private record As ADODB.Recordset
private objusername as variant
private objpassword as variant
Public Sub login(objuser As Variant, objpass As Variant)
Set cn = New ADODB.Connection
cn.ConnectionString = "Provider=SQLOLEDB;Data Source=localhost\SQLExpress;Initial Catalog=bdd;User ID=" & objusername & ";Password=" & objpassword & ""
cn.Open
If cn.State = adStateOpen Then
MsgBox "welcome", vbOKOnly, "connexion"
End If
end sub
Private Sub Class_Initialize()
On Error GoTo erreur
Set cn = New ADODB.Connection
Set record = New ADODB.Recordset
cn.ConnectionString = "Provider=SQLOLEDB;Data Source=localhost\SQLExpress;Initial Catalog=bdd;User ID='" & objusername & "';Password='" & objpassword & "'"
cn.Open
Exit Sub
erreur:
If Err.Number = -2147217843 Then
MsgBox "connection failed"
End If
End Sub
and I call class like this but I have always an error.
Private Sub CmdOK_Click()
dim x as class1
set x = new class1
x.Login text1,text2
End Sub
How can I solve this.
Class_Initialize will execute when you call new class1, as that's before you call Login the code in Class_Initialize has no idea what the username and password are.
Connect in Login instead:
private cn as ADODB.Connection
private record As ADODB.Recordset
private objusername as variant
private objpassword as variant
Public Sub login(objuser As Variant, objpass As Variant)
objusername = objuser
objpassword = objpass
Set cn = New ADODB.Connection
cn.ConnectionString = "Provider=SQLOLEDB;Data Source=localhost\SQLExpress;Initial Catalog=bdd;User ID=" & objusername & ";Password=" & objpassword & ""
cn.Open
...
end sub
Private Sub Class_Initialize()
End Sub
If you want to connect when you create an instance of Class1 use a factory function in a module which is the closest workaround for the lack of constructors.
public function CreateAndLogin(objuser As Variant, objpass As Variant) as class1
set CreateAndLogin= new Class1
CreateAndLogin.login bjuser, objpass
end function
called with
Dim cls as Class1
set cls = CreateAndLogin(text1, text2)

Outlook mail message into excel using VBA

Excel File Link
This is a code from an you-tube video. The below code is giving an Compiler error : Userdefined Type not defined.
Sub SendEmail(what_address As String, Subject_line As String, mail_body As String)
'Dim olApp As Outlook.Application
Set olApp = CreateObject("outlook.Application")
'Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = what_address
olMail.Subject = Subject_line
olMail.body = mial_body
olMail.send
End Sub
Sub SendMassEmail()
row_number = 1
Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim Promoscode As String
mail_body_message = Sheet1.Range("J2")
full_name = Sheet1.Range("B" & row_number) & " " & Sheet1.Range("C" & row_number)
promo_code = Sheet1.Range("D" & row_number)
mial_body_message = Replace(mail_body_message, "replace_name_here", full_name)
Call SendEmail(Sheet1.Range("A1" & row_number), "This is a test e-mail", mail_body_message)
Loop Until row_number = 6
End Sub
I am having an compiler error, I have checked everything but...not sure what is cousing this issue.
Use the Recipients property of the MailItem class to specify the recipients instead of the To property.
The Recipients class provides the Add method which allows to create and add a new recipient to the collection. Then use the Resolve method to attempt to resolve a Recipient object against the Address Book.
Sub AssignTask()
Dim myItem As Outlook.TaskItem
Dim myDelegate As Outlook.Recipient
Set MyItem = Application.CreateItem(olTaskItem)
MyItem.Assign
Set myDelegate = MyItem.Recipients.Add("DL name")
myDelegate.Resolve
If myDelegate.Resolved Then
myItem.Subject = "Prepare Agenda For Meeting"
myItem.DueDate = Now + 30
myItem.Display
myItem.Send
End If
End Sub

How to retrieve data from external device through Winsock to Microsoft Visual Basic (VB6)

I need to make an application that needs to retrieve data from an external terminal booking device to my application, with a telnet connection and show it on the txtOutput textbox.
I am pretty new in VB and used some time to learn the basics of the language.
First I created a Standard EXE project and added the Winsock control to the form.
I made a ping-request to the IP address I wanted to have connection too and it works.
Then I want to send a command to the external device. I want the booking-terminal to give me feedback to the txtOutput for me to read.
I made the connection and as much as I can see, I do send my messages to the terminal. But I don't get any responses from it! Nothing from it is viewed on my txtOutput.
How can that be?
Here is my code:
Dim IPAddress As String
Dim PortNum As Integer
Private Sub cmdConnect_Click()
Winsock.Close
Winsock.RemoteHost = txtIpaddress.Text
IPAddress = Winsock.RemoteHost
PortNum = CStr(txtPortnr.Text)
If (Val(PortNum) > 65535) Then
Winsock.RemotePort = (Val(PortNum) - 65535)
PortNum = Winsock.RemotePort
Else
Winsock.RemotePort = Val(PortNum)
PortNum = Winsock.RemotePort
End If
Winsock.Connect
Module1.send_to_buffer ("Attempting connection to: " & IPAddress & ":" & CStr(PortNum))
Call wsock_status
End Sub
Private Sub Winsock_Connect()
Module1.send_to_buffer ("Succeeded connection to: " & IPAddress & ":" & CStr(PortNum))
txtSend.SetFocus
End Sub
Private Sub cmdSend_Click()
Dim strSData As String
Dim message_to_send As String
If (Winsock.State = 0) Then
Module1.send_to_buffer ("You need to connect first!")
txtSend.Text = ""
Else
strSData = txtSend.Text
Winsock.SendData strSData & vbCrLf
message_to_send = txtSend.Text
If (message_to_send <> "") Then
Winsock.SendData message_to_send & vbCrLf
Module1.send_to_buffer_norm (txtSend.Text)
txtSend.Text = ""
txtSend.SetFocus
Else
Module1.send_to_buffer ("Nothing to send!")
txtSend.Text = ""
txtSend.SetFocus
End If
End If
End Sub
Private Sub terminalConnector_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
Winsock.GetData strData
If (Len(txtOutput.Text) = 0) Then
txtOutput.Text = strData & vbCrLf
Else
txtOutput.Text = txtOutput.Text & strData & vbCrLf
End If
End Sub
Private Sub cmdDisconnect_Click()
Dim Counter As Long
If (Winsock.State <> 0) Then
Winsock.Close
Call wsock_status
Module1.send_to_buffer ("Connection to " & IPAddress & ":" & CStr(PortNum) & " closed.")
End If
End Sub
Private Sub Winsock_Close()
Module1.send_to_buffer ("Disconnected from: " & IPAddress & ":" & CStr(PortNum))
Winsock.Close
End Sub
and Module1 code:
Public Function send_to_buffer(text_to_display As String)
If (Len(terminalConnector.txtOutput.Text) = 0) Then
terminalConnector.txtOutput.Text = "*** " & text_to_display
Else
terminalConnector.txtOutput.Text = terminalConnector.txtOutput.Text & vbCrLf & "*** " & text_to_display & vbCrLf & vbCrLf
End If
End Function
Public Function send_to_buffer_norm(text_to_input As String)
If (Len(terminalConnector.txtOutput.Text) = 0) Then
terminalConnector.txtOutput.Text = "> " & text_to_input & vbCrLf
Else
terminalConnector.txtOutput.Text = terminalConnector.txtOutput.Text & "> " & text_to_input & vbCrLf
End If
End Function
Thanks in advance
The DataArrival event is named wrongly :
in your code it is :
Private Sub terminalConnector_DataArrival(ByVal bytesTotal As Long)
but it should be the name of your winsock control :
Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
You can always select the controlname in the combobox on the left above your code window in the IDE and then select the eventname in the combobox on the right above your code window in the IDE, which will put the outlines of the event code in your code window.
Or you can double-click the control on the design window in the IDE, which will bring you to the code window and put the outlines of an event code in your code window .. you can then select the event you want in the combobox on the right above your code window
A side comment : Winsock might is not the best name for a winsock control, it is best to give it a more unique same, which could be as simple as wskConnection or wskTerminal
When you download MZ-tools you can "Review Source Code" which will show you any procedures and variables that will not be called or used in your program ... this will often give an extra hint to misnamed variables or procedures
You Send routine is wrong :
Private Sub cmdSend_Click()
Dim strSData As String
txtSend.Text = strSData
Winsock.SendData strSData
End Sub
You are showing strSata in txtSend ... while strSData is still an empty string .. after that you send the empty string via the Winsock control
you probably meant :
Private Sub cmdSend_Click()
Dim strSData As String
strSData = txtSend.Text
Winsock.SendData strSData
End Sub
Which reads txtSend.Text into your string variable, and then sends that via the Winsock control
The server probably wants some special character at the end of your string, so dont forget to add that ... usually you have to add a cariage return :
strSData = strSData & vbCr

Connection String in Textbox

I'am new in programming and my problem is. i have put my ado db connection string into a text box how can i call that text box? i'm creating my program in vb 6 and here's my code.
Private Sub lvButtons_H2_Click()
On Error GoTo errtrap
If Label47.Caption = "True" Then
MsgBox "INITIAL SETTING FOR SHIP ACCOUNT IS BEING PERFORMED", vbOKOnly, "ABORT"
Exit Sub
End If
Dim conas As New ADODB.Connection, rs01 As New ADODB.Recordset, rsx1 As New ADODB.Recordset, RS9 As New ADODB.Recordset
conas.Connectio`enter code here`nString = Text1155.Text
conas.Open
Set RS9 = New ADODB.Recordset
RS9.ActiveConnection = conas
RS9.CursorType = 3
RS9.LockType = 3
RS9.Open ("SELECT * FROM [SHIPACCOUNT].[dbo].[SPARE PART LIST BOND 29 MONTHLY] WHERE NAMECODE = " & Text2.Text & "")
Set DataReport2.DataSource = RS9
DataReport2.Sections("Section2").Controls.item("LABEL12").Caption = Text1.Text
DataReport2.Sections("Section2").Controls.item("LABEL11").Caption = Text3.Text
DataReport2.Sections("Section1").Controls.item("TEXT1").DataField = RS9![PARTSNAME].Name
DataReport2.Sections("Section1").Controls.item("TEXT2").DataField = RS9![Price].Name
DataReport2.Sections("Section1").Controls.item("TEXT3").DataField = RS9![unit].Name
DataReport2.Sections("Section1").Controls.item("TEXT4").DataField = RS9![QTYAPPLY].Name
DataReport2.Sections("Section1").Controls.item("TEXT5").DataField = RS9!QTYAPPROVE.Name
DataReport2.Sections("Section1").Controls.item("TEXT6").DataField = RS9![AMOUNTAPPROVE].Name
DataReport2.Sections("Section1").Controls.item("TEXT7").DataField = RS9![Date].Name
DataReport2.Show 1
Exit Sub
errtrap:
MsgBox Err.Description, vbCritical, "The system encountered an error"
End Sub
You can pass the connection string as parameter to the Connection.Open method
Such as (assuming the name of the textbox is Text1155):
Dim conas As New ADODB.Connection
conas.Open Text1155.Text
(You don't need parenthesis for calling a Sub in vb6)
Your code looks right otherwize...

Resources