VB Tutor..

Determines the number of workdays within a date range in visual basic

2011-05-02T03:46:00.000-07:00

I used implicit If Statements (IIF) because they take less lines of code, and this procedure is convoluted enough without making is bigger! In case you aren't familiar with them, they are a hold-over from VBA.
The first argument is the expression, the second is what to do if it's true, the third is what to do if it's false.
The first part determines the number of days between 2 dates. The second part determines the number of whole weeks because each whole week has a Saturday & a Sunday in it. The last part determines if the range spanned a weekend but not a whole week so it can subtract the
weekend out.

Private Sub FindWorkDays()
Dim A1 As Date
Dim A2 As Date
Dim iWorkDays As Integer

A1 = Text1.Text
A2 = Text2.Text

iWorkDays = A2 - A1 + 1 - Int((A2 - A1 + 1) / 7) * 2 - _
IIf(Int((A2 - A1 + 1) / 7) = (A2 - A1 + 1) / 7, 0, _
IIf(WeekDay(A2) < WeekDay(A1), 2, 0)) - _
IIf((WeekDay(A1) = 1 Or WeekDay(A2) = 7), 1, 0)

Label1.Caption = iWorkDays

End Sub

To Pause your application for a length of time without a timer control

2011-05-02T03:45:00.001-07:00

First put this code either in a module as a private function on a form

Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Then when you want to pause something just do this
Sleep 1000 'Pause for 1 second

Crystal Report in Visual basic

2011-05-02T03:35:00.000-07:00

Crystal Report is a Report Writer that comes with the professional edition of Visual
Basic. It is used to perform the following functions.

1. Design how the report looks
2. Add groupings that break every time the data in this group is changed.
3. Add subtotals based on these groupings, if desired.

The Report Writer is designed in two steps.

1.Design the report layout in the crystal reports design environment.
Write code in your Visual Basic application that runs the report designed in the
previous step.
2. To access the design environment - simply click the Add – Ins | Report Designer
menu option. This brings up two registration screen which contains information for
registering

Creating formulas in data reports in Visual basic

2011-05-02T03:33:00.000-07:00

If you want to create a formula to calculate numeric values, compare one value to
another and select alternative actions based on the comparison, join multiple text
strings into a single string, make data calculations or comparisons, etc.:

1 Click the Insert Formula button on the button bar. The Insert Formula dialog box
appears.
2 Enter a name for your formula and click OK. The Formula Editor appears. Use the
Formula Editor to create, test and modify your formula.
3 Enter fields, operators, and functions into the Formula text box by double-clicking
them in their respective list boxes. You can get complete information on each
available Function and Operator via the Help button.

Note Each formula is a text string that can be typed directly in to the Formula text
box as well as selecting components from the list boxes.

4 When finished editing, click the Accept button. Crystal Reports checks the formula
syntax, and if correct, closes the Formula Editor.
5 Place the formula field where you want it to appear in your report.

Adding a graph, chart to crystal report in Visual basic

2011-05-02T03:32:00.000-07:00

Crystal Reports enables you to include sophisticated, colorful charts and graphs in
your reports.
When you add a graph to your report, you are graphing summary and subtotal
information. Before you can add a graph, therefore, you must have at least one group
and one summary or subtotal in your report. For example, if you have a sales report
grouped by State and a subtotal of Last Year’s Sales for each State, you can quickly
create a graph that will display sales by state.
Adding and modifying your graphs is easy in Crystal Reports with the use of the
Graph/Chart Expert. Use the Expert every time you create or modify graphs. The
Expert walks you through the creation of your graphs step-by-step.

1 Click the Insert Chart button on the button bar to access the Graph/Chart Expert.

Types

Tab

When you begin creating your graphs, you will need to choose one of the many
graph types available. To select a graph type, click the button that corresponds to
the graph type you want.

Data

Tab

In the Data Tab, select what data you want to graph on, how often you want it to
print (dependent on where you want it displayed), and what you want to show in
the graph.
The graph on drop-down box displays all the summaries and subtotals on your
report. Simply select which one you want to base your graph on.

Text

Tab

The Text Tab allows you to enter labels for your graph by inserting titles,
footnotes, and axis titles when appropriate. Simply type the text into the
corresponding boxes. The program will only use the labels appropriate for the
graph type that you chose earlier. The others will be ignored.

Options

Tab

The Options Tab enables you to place a legend on your graph, a maximum or
minimum limit on the graph values, or a number of other options.

OLE Objects
Crystal Reports is an OLE container application. Thus it allows you to place OLE
objects in your report. To do this:
1 Choose the Object command from the Insert menu.
2 Insert an existing object by choosing the Create from file option and selecting the
desired object, or create a new object by choosing the Create New option then an
object type. The corresponding application will open where you can create the
object as desired.
3 If you want to edit the object, simply double-click it and the program in which it
was created (or a similar application that allows such editing) will open.
4 Modify the object as desired, save it and Crystal Reports automatically updates the
object in your report.

Variables Used by All Modules in Visual basic

2011-05-02T03:31:00.001-07:00

To make a module-level variable available to other modules, use the Public
keyword to declare the variable. The values in public variables are available to
all procedures in your application. Like all module-level variables, public
variables are declared in the Declarations section at the top of the module. For
example:
Public intTemp As Integer

Note You can't declare public variables within a procedure, only within the
Declarations section of a module.

Variables Used Within a Module in Visual basic

2011-05-02T03:30:00.001-07:00

By default, a module-level variable is available to all the procedures in that module, but not to code in other modules. You create module-level variables by declaring them with the Private keyword in the Declarations section at the top of the module. For example:

Private intTemp As Integer

At the module level, there is no difference between Private and Dim, but Private is preferred because it readily contrasts with Public and makes your code easier to understand.

Passing Arguments By Reference in VB

2011-05-02T03:28:00.000-07:00

Passing arguments by reference gives the procedure access to the actual variable
contents in its memory address location. As a result, the variable's value can be
permanently changed by the procedure to which it is passed. Passing by
reference is the default in Visual Basic.
If you specify a data type for an argument passed by reference, you must pass a
value of that type for the argument. You can work around this by passing an
expression, rather than a data type, for an argument. Visual Basic evaluates an
expression and passes it as the required type if it can.
The simplest way to turn a variable into an expression is to enclose it in
parentheses. For example, to pass a variable declared as an integer to a
procedure expecting a string as an argument, you would do the following:

Sub CallingProcedure()
Dim intX As Integer
intX = 12 * 3
Foo(intX)
End Sub

Sub Foo(Bar As String)
MsgBox Bar 'The value of Bar is the string "36".
End Sub

Adding Methods to the Object in Vb

2011-05-02T03:27:00.001-07:00

Add a new subroutine to the class module. This sub must be publicly available
and named deposit. Add code to the new method to increase the balance by a
given amount.
Add a new function to the class module. This function should be publicly
available and named withdraw. Add code to the new method to decrease the
balance by a given amount.

Methods of Interfacing with the jet Database Engine

2011-05-02T03:25:00.000-07:00

Visual Basic provides two methods of interfacing with the Jet database engine: the Data control and data access objects. While the Data control gives you limited ability to access existing databases without programming, the DAO model is a complete programming interface that gives you total control of the database. These two methods are not mutually exclusive; in fact, there are many situations where you will want to use both of them together.
The DAO model is a collection of object classes that model the structure of a
relational database system. They provide properties and methods that allow you
to accomplish all of the operations necessary to manage such a system, including
facilities for creating databases, defining tables, fields and indexes, establishing
relations between tables, navigating and querying the database, and so on.
The Jet database engine translates these operations on data access objects
into physical operations on the database files themselves, handling all the
mechanics of interfacing with the different supported databases.
Database programming in Visual Basic consists of creating data access
objects, such as Database, TableDef, Field, and Index objects, that correspond to
the various parts of the physical database you want to access. You use the
properties and methods of these objects to perform operations on the database.
You can display the results of these operations and accept input from the user on
Visual Basic forms, using both bound and unbound controls.
This approach simplifies the code you need to write and insulates you from
the underlying structure and mechanics of retrieving and updating data. It gives
you great flexibility, because you can use the same objects, properties, and
methods to work with a wide variety of supported database formats. Also, if you
change from one database format to another (for example, porting a local
Microsoft Access database to a SQL Server database on a network), you'll need
to make few changes in your code to accommodate the change. You can even
create applications that join tables from two or more different databases in a
single query or report.

Data Manipulation (DML) in Visual basic

2011-05-02T03:24:00.000-07:00

DML consists of the properties and methods that you use to write applications
that access and manipulate existing databases. This includes facilities for
querying the database, navigating through its tables, performing updates, and
adding or deleting records.
If you are working exclusively with databases that have already been created by
another application, it is possible to create applications entirely within the DML
functionality. Understanding the DDL methods, however, will add to your
knowledge of database structure and make you a more flexible database
programmer
There are many ways of organizing databases. Among the most popular are
indexed sequential access method (ISAM) file systems, network-model
databases, hierarchical databases, and relational databases. These types of
databases differ not only in the way they physically manage the storage and
retrieval of data, but also in the conceptual models they present to the user and
programmer.
In recent years, the relational model has generally become the de facto standard
for database design. This is due both to the power of the relational model itself,
and because it provides a standard interface called Structured Query Language
(SQL) that allows many different database tools and products to work together
in a consistent and understandable way. The Microsoft Jet database engine is a
relational database engine.
The relational database model presents the data as a collection of tables. Instead
of modeling the relationships in the data according to the way that it is
physically stored, the structure is defined by establishing relations between
simple tables.

Database Normalization in VB in Visual basic

2011-05-02T03:23:00.000-07:00

The task of the database designer is to structure the data in a way that
eliminates unnecessary duplication and provides a rapid search path to all
necessary information. The process of dividing the information into separate
tables that meet these goals is called normalization.
Normalization can be a complex process with many specific rules and different levels of normal form. For a complete discussion of the process one must refer to advanced books. However, normalizing most simple databases can be
accomplished by following a simple rule of thumb: tables that contain repeated information should be divided into separate tables to eliminate the duplication.

designates a field as a foreign key

2011-05-02T03:22:00.002-07:00

If the foreign table's primary key consists of more than one field, you must use a multiple-field index definition, listing all of the referencing fields, the name of the foreign table, and the names of the referenced fields in the foreign table in the same order that the referencing fields are listed. If the referenced field or fields are the foreign table's primary key, you don't have to specify the referenced fields by default the Jet engine behaves as if the foreign table's primary key is the referenced fields.

designates one field or set of fields in a table as a primary key

2011-05-02T03:22:00.001-07:00

All values in the primary key must be unique, and there can be only one
primary key for a table. If you set a PRIMARY KEY constraint on a table
that already has a primary key, an error occurs.

field as a unique key

2011-05-02T03:21:00.000-07:00

This means that no two records in the table can have the same value in this field. You can constrain any field or list of fields as unique. If a multiple-field index is designated as a unique key, the combined values of all fields in the index must be unique, evenif two or more records have the same value in just one of the fields.

Using Visual Basic Variables in an SQL Statement

2011-05-02T03:19:00.000-07:00

In a Visual Basic program, you can create a SELECT statement in your
application by concatenating local variables into the statement as needed to
select, sort, or filter the data as dictated by your application. For example, if you
have a TextBox control (TitleWanted) containing the name of a Title and you
want to fetch all books from the Titles table with this title, you can create an
SQL statement that includes the current value of the TextBox. Note that the
SQL query encloses the TitleWanted value in single quotation marks (' '):
Set Rst = Db.OpenRecordset("SELECT * FROM Titles " _
& " WHERE Title = '" & TitleWanted.T

The procedure for creating a new Jet database is simply a process of creating
and defining data access objects that correspond to the tables, fields, indexes,
and relations of your database design. In this overview, the process will be
presented step-by-step, followed by a complete code example for creating the
Biblio.mdb database.
The first step in creating a new database is to create the Database object itself,
and to define its structure by adding TableDef and Field objects that correspond
to your design.

To create a new database
1 Use the Dim statement to create new object variables for each object in your
database. In addition to the DBEngine and default Workspace objects that
make up the working environment, you will need:
One Database object
One TableDef object for each table
One Field object for each field in each table
One Index object for each index in each table
For example, to create object variables for the Biblio.mdb database, you could
use the following code:
Dim MyDB As Database, MyWs As Workspace
Dim AuTd As TableDef, TitTd As TableDef, _
PubTd As tableDef
Dim AuFlds(2) As Field, TitFlds(5) _
As Field, PubFlds(10) As Field
Dim AuIdx As Index, TitIdx(3) As Index, _
PubIdx As Index

2 Use the CreateDatabase method of the Workspace object to create the new
database. In this example, the method uses the minimum two arguments: one
to specify the database name, and one to specify the locale:
Set MyWs = DBEngine.Workspaces(0)
Set MyDb = MyWs.CreateDatabase("C:\VB\Biblio.mdb", _
dbLangGeneral, dbVersion30)

Note that the constant dbVersion30 specifies a Jet version 3.0 database. If you
use the dbVersion30 constant to create a version 3.0 database, only 32-bit
applications using the Jet version 3.0 engine or higher will be able to access it.
3 Use the CreateTableDef method of the Database object to create new
TableDef objects for each table in the database, as follows:
Set TitTd = MyDB.CreateTableDef("Titles")
Set AuTd = MyDB.CreateTableDef("Authors")
Set PubTd = MyDB.CreateTableDef("Publishers")

4 Use the CreateField method of the TableDef object to create new Field objects
for each field in the table, and to set properties of each field to define the
field's size, data type, and other needed attributes. For example, the following
code creates the Authors table in the Biblio.mdb database:
Set AuFlds(0) = AuTd.CreateField("Au_ID", dbLong)
' Make it a counter field.
AuFlds(0).Attributes = dbAutoIncrField
Set AuFlds(1) = MyTd.CreateField("Author", dbText)
AuFlds(1).Size = 50

5 Use the Append method to add each field to its table and each table to the
database, as shown in the following code:
AuTd.Fields.Append AuFlds(0)
AuTd.Fields.Append AuFlds(1)
MyDB.TableDefs.Append AuTd

Access from your application to a data source is through a connection ADO

2011-05-02T03:18:00.000-07:00

The object model embodies the concept of a connection with the Connection object.

A transaction delimits the beginning and end of a series of data access operations
that transpire across a connection. ADO ensures that changes to a data source
resulting from operations in a transaction either all occur successfully, or not at all.
If you cancel the transaction or one of its operations fails, then the ultimate result
will be as if none of the operations in the transaction had occurred. The data source
will be as it was before the transaction began.

The object model does not explicitly embody the concept of a transaction, but
represents it with a set of Connection object methods.

ADO accesses data and services from OLE DB providers. The Connection object is
used to specify a particular provider and any parameters. For example, Remote
Data Service (RDS) can be invoked explicitly or it can be invoked implicitly with the
"MS Remote" provider.

Basic ADO Programming Model in Visual basic

2011-05-02T03:17:00.000-07:00

ADO provides the means for you to perform the following sequence of actions:

1. Connect to a data source. Optionally, you can ensure that all changes to the
data source occur either successfully or not at all.

2. Specify a command to gain access to the data source, optionally with variable parameters, or optionally optimized for performance.

3. Execute the command.

4. If the command causes data to be returned in the form of rows in a table,
store the rows in a cache that you can easily examine, manipulate, or change.

5. If appropriate, update the data source with changes from the cache of rows.

6. Provide a general means to detect errors (usually as a result of making a
connection or executing a command).

Typically, you will employ all these steps in the programming model. However, it's
worth noting that ADO is flexible enough that you can do useful work by executing just part of the model. For example, you could store data from a file directly into a cache of rows, then use ADO resources merely to examine the data.

The RDS Object Model Summary in Visual basic

2011-05-02T03:16:00.001-07:00

RDS.DataSpace

RDSServer.DataFactory

RDS.DataControl

Description
This object only contains a method to obtain a
server proxy. The proxy may be the default or a
custom server program (business object). The
server program may be invoked on the Internet, an
intranet, or local area network, or be a local
dynamic-link library.
This object represents the default server program.
It executes the default RDS data retrieval and
update behavior.
• This object can automatically invoke the
RDS.DataSpace and
RDSServer.DataFactory objects.

• Use this object to invoke the default RDS
data retrieval or update behavior.

• This object also provides the means for
visual controls to access the returned
Recordset object.

RDS Programming Model with Objects in VB Visual baisc

2011-05-02T03:14:00.000-07:00

The goal of RDS is to gain access to and update data sources through an
intermediary like the Internet Information Server. The programming model
specifies the sequence of activities necessary to accomplish this goal. The object
model specifies the objects whose methods and properties affect the programming model.
RDS provides the means to perform the following sequence of actions:
13. Specify the program to be invoked on the server, and obtain a way (proxy) to
refer to it from the client. (RDS.DataSpace)

14. Invoke the server program. Pass parameters to the server program that
identify the data source and the command to issue. (proxy or
RDS.DataControl)

15. The server program obtains a Recordset object from the data source,
typically by using ADO. Optionally, the Recordset object is processed on the
server. (RDSServer.DataFactory)

16. The server program returns the final Recordset object to the client
application. (proxy)

17. On the client, the Recordset object is put into a form that can be easily used
by visual controls. (visual control and RDS.DataControl)

18. Changes to the Recordset object are sent back to the server and used to
update the data source. (RDS.DataControl or RDSServer.DataFactory)

Creatiung forms during Run Time in visual basic

2011-05-02T03:12:00.000-07:00

Private Sub Command1_Click()
Dim x As New frmTest
x.Caption = "Test Form" & Forms.Count
x.Show
End Sub

Private Sub Command2_Click()
MsgBox "The Forms collection contains " & Forms.Count & " loaded forms."
End Sub

Private Sub Command3_Click()
Dim iLoop As Integer
For iLoop = Forms.Count - 1 To 0 Step -1
Unload Forms(iLoop)
Next iLoop
End Sub
Option Explicit

Private Sub Form_Load()

'Set the Drag icon of the control
'lstOrginal.DragIcon = imgList.ListImages("DRAG").ExtractIcon
End Sub

Private Sub lstDestination_DragDrop(Source As Control, X As Single, Y As Single)
If Source Is lstOrginal Then
If Source.ListIndex > -1 Then
lstDestination.AddItem Source.List(Source.ListIndex)
Source.RemoveItem Source.ListIndex
End If
End If
End Sub

Private Sub lstOrginal_MouseDown(Button As Integer, Shift As Integer, X As Single, Y
As Single)
lstOrginal.Drag vbBeginDrag
Private Sub lstOrginal_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As
Single)

lstOrginal.Drag vbEndDrag

End Sub

Calling a DLL Procedure in visual baisc

2011-05-02T03:11:00.000-07:00

Option Explicit

Private Declare Function GetComputerNameA Lib "kernel32" _
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function WNetGetUserA Lib "mpr" _
(ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As
Long
Private Declare Function GetWinDir Lib "kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Sub cmdGetComputerName_Click()
Dim strBuffer As String, lResult As Long
strBuffer = String(255, 0)
lResult = GetComputerNameA(strBuffer, Len(strBuffer))
If lResult <> 0 Then
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
txtGetComputerName.Text = strBuffer
End If
End Sub

Private Sub cmdGetUserName_Click()
Dim strUserName As String, lResult As Long
strUserName = String(255, 0)
lResult = WNetGetUserA(vbNullString, strUserName, Len(strUserName))
If lResult = 0 Then
strUserName = Left$(strUserName, InStr(strUserName, vbNullChar) - 1)
txtGetUserName.Text = strUserName
End If

End Sub

Private Sub cmdGetWindowsDirectory_Click()
Dim strWindowsDir As String, lResult As Long
strWindowsDir = String(255, 0)
lResult = GetWinDir(strWindowsDir, Len(strWindowsDir))
strWindowsDir = Left$(strWindowsDir, lResult)
txtGetWindowsDirectory.Text = strWindowsDir
End Sub
Figure 3a
Option Explicit

Private Declare Function GetComputerNameA Lib "kernel32" _
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function WNetGetUserA Lib "mpr" _
(ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As
Long
Private Declare Function GetWinDir Lib "kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Sub cmdGetComputerName_Click()
Dim strBuffer As String, lResult As Long
strBuffer = String(255, 0)
lResult = GetComputerNameA(strBuffer, Len(strBuffer))
If lResult <> 0 Then
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
txtGetComputerName.Text = strBuffer
End If
End Sub

Private Sub cmdGetUserName_Click()
Dim strUserName As String, lResult As Long
strUserName = String(255, 0)
lResult = WNetGetUserA(vbNullString, strUserName, Len(strUserName))
If lResult = 0 Then
strUserName = Left$(strUserName, InStr(strUserName, vbNullChar) - 1)
txtGetUserName.Text = strUserName
End If
End Sub

Private Sub cmdGetWindowsDirectory_Click()
Dim strWindowsDir As String, lResult As Long
strWindowsDir = String(255, 0)
lResult = GetWinDir(strWindowsDir, Len(strWindowsDir))
strWindowsDir = Left$(strWindowsDir, lResult)
txtGetWindowsDirectory.Text = strWindowsDir
End Sub

Project using ImageList Control in visual basic

2011-05-02T03:10:00.000-07:00

Option Explicit

Private Sub cmdLoadBitmap_Click()

If Val(txtBitmaps) = 0 Then

MsgBox "Enter a number between 1 and 9."

txtBitmaps.SetFocus

Exit Sub

End If

Image2.Picture = imgBitmaps.ListImages(Val(txtBitmaps)).Picture

End Sub

Private Sub cmdLoadIcon_Click()

If Val(txtIcons) = 0 Then

MsgBox "Enter a number between 1 and 9."

txtIcons.SetFocus

Exit Sub

End If

Image1.Picture = imgIcons.ListImages(Val(txtIcons)).Picture

End Sub

Runtime Visual Basic and access Database Connectivity | Retrieving values in Visual basic from Access

2010-07-25T08:02:00.000-07:00

Private Sub Form_Load()
Adodc1.ConnectionString = "provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\demo\pop.mdb;Persist Security Info=False"
Adodc1.RecordSource = "select * from pop
Set Text1.DataSource = Adodc1
Set Text2.DataSource = Adodc1
End Sub

Private Sub Command1_Click()
On Error Resume Next
Adodc1.Recordset.AddNew
With Adodc1.Recordset
.Fields(0) = Text1.Text
.Fields(1) = Text2.Text
End With
Adodc1.Recordset.Save
Adodc1.Recordset.Close
End Sub

fibonacci series in visual basic

2010-07-25T08:00:00.000-07:00

Dim i, f1, f2, f3, n As Integer
Private Sub Command1_Click()
n = Text1.Text
i = 3
While (i <= n)
f3 = f1 + f2
f1 = f2
f2 = f3
Next
Print f3
End Sub

Visual Basic connectivity data grid

2010-07-25T07:53:00.000-07:00

Dim x As Integer
Private Sub Command1_Click()
x = Text1.Text
Data1.RecordSource = "select * from employees where EmployeeID =" & x
Data1.Refresh
End Sub

Visual basic Database connectivity with Oracle

2010-07-25T06:55:00.000-07:00

Dim sql As String
Dim rs1 As New Adodb.Recordset
Dim cn As New Adodb.Connection

Private Sub Command1_Click()
rs1.AddNew
rs1.Fields("rno").Value = Text1.Text
rs1.Fields("name").Value = Text2.Text
rs1.Update
End Sub

Private Sub Form_Load()
Set rs1 = New Adodb.Recordset
cn = New Adodb.Connection
cn.CursorLocation = adUseClient
cn.Open "provider=msdaora.1;", "scott", "tiger"
sql = "select * from pop"
rs1.Open sql, cn, adOpenDynamic, adLockOptimistic
End Sub

creating popup menu in vb6, right click menu in vb6

2010-07-25T06:51:00.000-07:00

Private Sub Form_MouseUp(Button As Integer, Shift As _
Integer, X As Single, Y As Single)
If Button = 2 Then

PopupMenu mnuFile

End If
End Sub

MSFLEX in visual basic

2010-07-25T06:49:00.001-07:00

Public cn As ADODB.Connection
Public rs As ADODB.Recordset
Private Sub Command1_Click()
MS.Rows = 1
Text3.Text = ""
Dim cmd As ADODB.Command
Dim cmdtxt As String
cmdtxt = ""
Me.MousePointer = vbHourglass
Set cn = New ADODB.Connection
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=pop.mdb;Persist Security Info=False"
cn.Open
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.CursorType = adOpenStatic
Set cmd = New ADODB.Command
cmd.CommandType = adCmdText
Set cmd.ActiveConnection = cn
If Option1.Value = True Then
cmdtxt = "Select * from abc where name=" & "'" & Text1.Text + "'" + " order by rno"
Else
If Option2.Value = True Then
cmdtxt = "Select * from abc where rno=" & "'" & Text1.Text + "'" + " order by rno"
End If
End If
cmd.CommandText = cmdtxt
cmd.Prepared = True
Set rs = cmd.Execute
Me.MousePointer = 0
''''''''''''''''''''''''''
Dim r As Integer
r = 1
''''''''''''''''''''''''''Code For entering Data in MSFLEXgrid
Do While Not Me.rs.EOF
MS.AddItem Me.rs.Fields("RNO").Value
MS.Row = r
MS.Col = 1
MS.Text = Me.rs.Fields("name").Value
'MS.Col = 2

r = r + 1
Me.rs.MoveNext
Loop
''''''''''''''
Text3.Text = r - 1
Command2.Enabled = False

If Text3.Text = 0 Then MsgBox "not found"
End Sub

InputBox in vb6

2010-07-25T06:45:00.000-07:00

Private Sub Command1_Click()
stranswer = InputBox("what is ur name", "get name")
If (stranswer = "pop") Then
MsgBox "hello " + stranswer
Else
MsgBox stranswer + " Shut up!"
End If
End Sub

Area of circle vb tutor.

2010-07-25T06:42:00.000-07:00

Dim r, b, pi As Integer
Private Sub Command1_Click()
pi = 3.14
r = Text1.Text
b = pi * (r * r)
Label2.Caption = "The Area is " & b
End Sub

Private Sub Command3_Click()
Text1.Text = ""
Label2.Caption = ""
End Sub

Making a form invisible, but leaving (showing) the controls visible

2010-05-25T19:21:00.000-07:00

This involves using the SetWindowLong API function with the following parameters, GWL_EXSTYLE and WS_EX_TRANSPARENT as constants.

the syntax of the function using the paramters is

dim intresult as long

intresult = setwindowlong(me.hwnd, gwl_exstyle, ws_ex_transparent)

this will make the form referenced by me.hwnd transparent so that the background can be seen but the controls can still be accessed.

Program to Display a Form without a Titlebar. (Hide Title Bar)

2010-05-25T19:18:00.000-07:00

Often, an application needs a special window without a title bar, the horizontal
bar at the top of a window that contains the title of the window. For instance, a splash screen or a custom context sensitive menu are nothing more than VB forms without title bars. To make a form appear without a title bar set the following design-time and run-time properties.

Properties that must be set at design-time, they are read-only at
run-time:

ControlBox=False ' Turns off Control-menu: Restore, Move, Size,
Minimize, Maximize, Close
MaxButton=False ' Turns off Maximize button
MinButton=False ' Turns off Minimize button

ShowInTaskbar=False ' Hides window in Taskbar

'Properties that can be set at either run-time or design-time:

Caption="" ' Blanks window title

Program to Determines the number of workdays within a date range.

2010-05-25T19:16:00.001-07:00

Private Sub FindWorkDays()
Dim A1 As Date
Dim A2 As Date
Dim iWorkDays As Integer

A1 = Text1.Text
A2 = Text2.Text

iWorkDays = A2 - A1 + 1 - Int((A2 - A1 + 1) / 7) * 2 - _
IIf(Int((A2 - A1 + 1) / 7) = (A2 - A1 + 1) / 7, 0, _
IIf(WeekDay(A2) <>
IIf((WeekDay(A1) = 1 Or WeekDay(A2) = 7), 1, 0)

Label1.Caption = iWorkDays

End Sub

How To Pause your application for a length of time without a timer control in vb (Visual basic)

2010-05-25T19:08:00.000-07:00

First put this code either in a module as a private function on a form

Public Declare Sub Sleep Lib "kernel32.dll"
(ByVal dwMilliseconds As Long)

Then when you want to pause something just do this

Sleep 1000 'Pause for 1 second

Simple Hostel Management system Project In Visual basic

2010-02-01T04:44:00.000-08:00

Dim hrs As Recordset

Private Sub add_Click()
clr
hrs.AddNew
End Sub

Private Sub delete_Click()
a = MsgBox("Do you want to delete record?", vbQuestion + vbYesNo, "Record Deletion")
If a = vbYes Then
st = "delete * from Hostel_Data Where d_no = " & Val(tno) & ""
DB.Execute (st)
hrs.MoveNext
display
End If
End Sub

Private Sub first_Click()
hrs.MoveFirst
display
End Sub

Private Sub Form_Load()
Module1.hostel
Set hrs = DB.OpenRecordset("Hostel_Data", dbOpenTable)
End Sub

Private Function clr()
tno = Empty
tname = Empty
tadd = Empty
trent = Empty
End Function
Private Function display()
tno = hrs.Fields("d_no")
tname = hrs.Fields("d_name")
tadd = hrs.Fields("d_address")
trent = hrs.Fields("d_rent")
End Function

Private Sub last_Click()
hrs.MoveLast
display
End Sub

Private Sub modify_Click()
hrs.Edit
hrs.Fields("d_no") = Val(tno)
hrs.Fields("d_name") = Trim(tname)
hrs.Fields("d_address") = Trim(tadd)
hrs.Fields("d_rent") = Val(trent)
hrs.Update
MsgBox "Record Modified Successfully"
End Sub

Private Sub next_Click()
hrs.MoveNext
If hrs.EOF = True Then
hrs.MoveLast
End If
display
End Sub
S
Private Sub previous_Click()
hrs.MovePrevious
If hrs.BOF = True Then
hrs.MoveFirst
End If
display
End Sub

Private Sub save_Click()
hrs.Fields("d_no") = Val(tno)
hrs.Fields("d_name") = Trim(tname)
hrs.Fields("d_address") = Trim(tadd)
hrs.Fields("d_rent") = Val(trent)
hrs.Update
MsgBox "The record has been succesfully saved"
End Sub

Program showing Recordset ADODC Add, Update Example

2010-02-01T04:42:00.000-08:00

Dim crs As Recordset
Private Sub add_Click()
clr
crs.AddNew
End Sub

Private Sub delete_Click()
a = MsgBox("Do you want to delete record?", vbQuestion + vbYesNo, "Record Deletion")
If a = vbYes Then
st = "delete * from courses Where c_id = " & Val(tid) & ""
DB.Execute (st)
crs.MoveNext
display
End If
End Sub
Private Sub first_Click()
crs.MoveFirst
display
End Sub

Private Sub Form_Load()
Module.courses
Set crs = DB.OpenRecordset("courses", dbOpenTable)
End Sub

Private Function clr()
tid = Empty
tname = Empty
tfees = Empty
tseats = Empty
End Function

Private Function display()
tid = crs.Fields("c_id")
tname = crs.Fields("c_name")
tfees = crs.Fields("c_fees")
tseats = crs.Fields("c_seats")
End Function

Private Sub last_Click()
crs.MoveLast
display
End Sub

Private Sub modify_Click()
crs.Edit
crs.Fields("c_id") = Val(tid)
crs.Fields("c_name") = Trim(tname)
crs.Fields("c_fees") = Val(tfees)
crs.Fields("c_seats") = Val(tseats)
crs.Update
MsgBox "Record Modified Successfully"
End Sub

Private Sub next_Click()
crs.MoveNext
If crs.EOF = True Then
crs.MoveLast
End If
display
End Sub

Private Sub pre_Click()
crs.MovePrevious
If crs.BOF = True Then
crs.MoveFirst
End If
display
End Sub

Private Sub save_Click()
crs.Fields("c_id") = Val(tid)
crs.Fields("c_name") = Trim(tname)
crs.Fields("c_fees") = Val(tfees)
crs.Fields("c_seats") = Val(tseats)
crs.Update
MsgBox "The record has been succesfully saved"
End Sub

Program to create toolbar contain the following tools. Notepad, Wordpad, Calculator, Windows Explorer, Paint Brush, MS Word, MS PowerPoint

2009-12-19T01:53:00.000-08:00

Draw flowchart, write an algorithm and program in VB to create the toolbar.
Toolbar should contain the following tools.
Notepad, Wordpad, Calculator, Windows Explorer, Paint Brush, MS Word, MS PowerPoint, MS Excel.
User will click on any of the tools and related application should open.

Private Sub Toolbar1_ButtonClick(ByVal Button As
MSComctlLib.Button)
Select Case Button.Key
Case "a"
Shell "notepad"

Case "b"
Shell "C: \ Program
Files\WindowsNT\Accessories\Wordpad.exe"

Case "c"
Shell "C:\WINDOWS\system32\calc.exe"

Case "d"
Shell "explorer.exe"

Case "e"
Shell "C:\WINDOWS \system32\mspaint.exe"

Case "f"
Shell "C:\Program Files\Microsoft
office\Office10\Winword.exe"

Case"g"
Shell "C:\Program Filesl\Microsoft Office\Office10\powerpnt.exe"

Case"h"
Shell "C:\Program Filesl\Microsoft Office\Office10\excel.exe"

End Select

End Sub

Program to change fonts, font sizes in combo boxes and foreground, background color by using windows common control in Visual Basic

2009-12-19T01:50:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to enter the string from the user. Display any four fonts, font sizes in combo boxes and foreground, background color by using windows common control. Give the option of bold, italic, underline and strike through in check boxes. User will select any font, size, color, font style and that should be applicable on the text box.

Private Sub chkBold_Click()
txtfont.FontBold = chkBold
End Sub
Private Sub chkItalic_Click()
txtfont.FontItalic = chkItalic
End Sub
Private Sub chkUnderline_Click ()
txtfont.FontUnderline = chkUnderline
End Sub
Private Sub chkstrike_Click()
txtfont.FontStrikethru = chkstrike
End Sub
Private Sub cboName_Click()
txtfont. FontName = cboName.Text
End Sub

Private Sub cboSize_Click()
txtfont. FontSize = cboSize.Text
End Sub
Private Sub cmdBcolor_Click()
cdBcolor. ShowColor
txtfont. BackColor = cdBcolor. Color
End Sub
Private Sub cmdFcolor_click()
cdFcolor.ShowColor
txtfont. ForeColor = cdFcolor .Color
End Sub

basic to select a company name, display the names in combo box.

2009-12-19T01:40:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to select a company name, display the names in combo box.

Company Name: TVS, Hero Honda
After selecting the company name the list of corresponding vehicles Should be displayed in combo box.
Vehicle name: TVS-fiero, victor
: Hero Honda- Ambition,CBZ.
After selecting vehicle name the list of colors available and their rates should be displayed in combo box.
Colors: fiero- black, Red
: victor yellow , blue.
: Ambition black, silver.
: cbz Metallic & black
Price : fiero 50000 Rs.
Victor 45000 Rs.
Ambition 48000 Rs.
CBZ 52000 Rs.
Allow the user to select the bank. After selection the rate of interest should be displayed automatically
Bank: ICICI, HDFC
Rate of interest : ICICI: 9% HDFC: 9.4%
Allow the user to select the duration. Duration of installment 12,18,24 months.
Input down payment Calculate the balance amount , interest amount and EMI (equal months installments)

Dim dp As Integer
Dim emi, amt, roi As Single
Private Sub cboCompany_Click()
cboVehicle. Clear
If cboCompany.Text = "TVS" Then
cboVehicle.Addltem "Fiero" ,0
cboVehicle.Addltem "Vector", 1
Else
cboVehicle.Addltem "Ambition",0
cboVehicle.AddItem "CBZ", 1 End If
End Sub
Private Sub cboVehicle_Click()
cboColor. Clear
If cboVehicle. Text = "Fiero" Then
cboColor.AddItem "Black", 0
cboColor.AddItem "Red", 1
txtPrice.Text = "50000"
Elself cboVehicle.Text = "Victor" Then
cboColor.AddItem "Yellow", 0
cboColor.AddItem "Blue", 1
txtPrice.Text = "45000"
Elself cboVehicle.Text = "Ambition" Then
cboColor .Addltem "Black", 0
cboColor.Addltem "Silver", 1
txtPrice.Text = "48000"
Else: cboVehicle.Text = "Ambition"
cboColor.Addltem "Metallic", 0
cboColor.Addltem "Black", 1
txtPrice.Text = "52000"
End If
cboColor.Text = Clear
End Sub

Private Sub optHDFC_Click()
txtrate.Text = "9.4 %"
End Sub

Private Sub optICICI_Click()
txtrate.Text = "9 %"
End Sub

Private Sub
txtDPay_Validate (Cancel As Boolean)
dp = CInt(txtDPay.Text)

amt = CSng (txtPrice.Text) - dp
txtBalAmt.Text = CStr(amt)
If optICICI. Value = True Then
If opt12.Value = True Then
emi = ((amt * 9) / 100 + amt) / 12
Elself opt18.Value = True Then
emi = ((amt * 9) / 100 + (amt * 9) /100 / 2 + amt) / 18
Elself opt24.Value = True Then
emi = ((amt * 9) / 100 + (amt * 9) / 1000 * 2 + amt) / 24
End If
txtEMI. Text = emi
End If
If optHDFC.Value = True Then
If opt12.Value = True Then
emi = ((amt * 9.4) / 100 + amt) / 12
ElseIf opt18.Value = True Then
emi = ((amt * 9.4) / 100 + (amt * 9.4) / 100 / 2 + amt) 18
ElseIf opt24.Value = True Then
emi = ((amt * 9.4) / 100 + (amt * 9.4) / 1000 * 2 + amt) / 24
End If
txtEMI.Text = emi
End If
End Sub

create conditional report without data environment. Table must have fields students id,student name, parent name, address and date of admission.

2009-12-19T01:35:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to create conditional report without data environment. Table must have fields students id,student name, parent name, address and date of admission. Input two dates of admission from the user and display the entire record between the two dates.

Ans:

Dim con As New ADODB.Connection
Dim stdrs As New ADODB. Recordset

Private Sub Command1_Click()
If stdrs.State = adStateOpen Then
stdrs.Close
End If

stdrs.Open "select * from studtable where date_admission >= #" & DTPicker1.Value & "# and date_admission <= #" & DTPicker2.Value & "#", con, adOpenDynamic, adLockBatchOptimistic

If (stdrs.BOF = True And stdrs.EOF = True) Then
MsgBox "Record Not Found........"
Else
Set DataReport1.DataSource = stdrs
DataReport1.Sections("Section1") .Controls (1) .DataField = stdrs.Fields(0) .Name
DataReport1.Sections("Section1") .Controls (2) .DataField = stdrs.Fields(1) .Name
DataReport1.Sections("Section1") .Controls (3) .DataField = stdrs.Fields(2) .Name
DataReport1.Sections("Section1") .Controls (4) .DataField = stdrs.Fields(3) .Name

'DataReport1.Sections("Section1") .Controls (5) .DataField = stdrs.Fields(4) .Name
'DataReport1.Sections("Section1") .Controls (4) .Caption = DTPicker2.Value
DataReport1.Show
End If

End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Form_Load()
If con. State = adStateOpen Then
con.Close
End If
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=E: \ASSINGMENT\bloodreport.mdb; Persist Security Info=False"

If stdrs.State = adStateOpen Then
stdrs.Close
End If

stdrs.Open "select * from studtable", con, adOpenDynamic, adLockBatchOptimistic
DTPicker1.Value = Now()
DTPicker2.Value = Now()

End Sub

create a conditional report. Table must have fields donor number, donor name,address,age,and blood group.

2009-12-19T01:31:00.001-08:00

Draw flowchart, write an algorithm and program in visual basic to create a conditional report. Table must have fields donor number, donor name,address,age,and blood group. User will input the blood group name and the entire details having that blood group should be displayed.

Ans:

Dim con As New ADODB.Connection
Dim brs As New ADODB. Recordset
Private Sub Command1_Click()
If brs.State = adStateOpen Then
brs.Close
End If
brs.Open "select * from bloodgroupdetails where blood_group = '" &
Combo1.Text & "'", con, adOpenDynamic, adLockBatchOptimistic

If (brs.BOF = True And brs.EOF = True) Then
MsgBox "Record Not Found"
Else
Set DataReport2.DataSource = brs

DataReport2.Sections("Section1") .Controls (1) .DataField =
brs. Fields(0).Name
DataReport2. Sections("Section1") .Controls(2) .DataField =
brs. Fields (1) . Name
DataReport2. Sections("Section1") .Controls(3) .DataField =
brs. Fields(2) .Name
DataReport2.Sections("Section1") .Controls(4) .DataField =
brs. Fields(3). Name
DataReport2. Sections("Section1") .Controls(5) .DataField =
brs. Fields (4).Name
DataReport2.Show
End If
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Form_Load()
If con.State = adStateOpen Then
con.Close
End If
con.Open "Provider = Microsoft.Jet.OLEDB.4.0;Data
Source=E:\ASSINGMENT\bloodreport.mdb;Persist Security Info=False"
If brs.State = adStateOpen Then
brs.Close
End If
If brs. State = adStateOpen Then
brs.Close
End If
brs.Open "select * from bloodgroupdetails", con, adOpenDynamic,
adLockBatchOptimistic
End Sub

create a popup menu having cut, copy and paste options.

2009-12-19T01:28:00.001-08:00

Draw flowchart, write an algorithm and program in visual basic to create a popup menu having cut, copy and paste options. Apply these operations on the text in the text box.

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 2 Then
PopupMenu mnufile
End If
End Sub

Private Sub mnucopy_Click()
Clipboard.Clear
Clipboard.SetText txt1.SelText
End Sub

Private Sub mnucut_Click()
clipboard.SetText txt1.SelText
txt1.SelText = ""
End Sub

Private Sub mnupaste_Click()
txt1.SelText = Clipboard.GetText()
End Sub

Create the following menus. Math-AddSubstract, Multiply, Divide, Exit (Give separator before Exit)Trig-Sin, Cos, Tan.

2009-12-19T01:22:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to Create the following menus. Math-AddSubstract, Multiply, Divide, Exit (Give separator before Exit)Trig-Sin, Cos, Tan.After users selects any of the menus corresponding program should work.
Note: Use MDI form.

Dim n1,n2, result As Integer
Dim n3, n4, res1 As Integer
Private Sub cmdClick1_Click()
nl = CInt(txtnum1.Text)
n2 = CInt (txtnum2.Text)

If MDIForm1.opr = "A" Then
frmCalculate.fraArith.Caption = "ADDITION"
result = n1 + n2 txtResult1.Text = result
End If

If MDIForm1.opr = "S" Then
frmCalculate.fraArith.Caption = "SUBTRACTION" result = n1 - n2
txtResult1.Text = result
End If

If MDIForm1.opr = "M" Then
frmCalculate.fraArith.Caption = "MULTIPLICATION"
result = n1 * n2
txtResult1. Text = result
End If

If MDIForm1.opr = "D" Then
frmCalculate.fraArith.Caption = "DIVISION"
result = n1/n2
txtResult1.Text = result
End If
End Sub
Private Sub Command2_Click()
Unload Me
MDIForm1.Show
End Sub

Private Sub cmdClick2_Click()
n4 = CDb1 (Text 4. Text)
n3 = CDb1 (n4)
If MDIForm1. opr = "ST" Then
A = (n3 * 180)/360
res1 = Sin (A)
txtResult2.Text = res1
End If

If MDIForm1.opr = "C" Then
frmCalculate.fraTrig.Caption = "COS OF ANGLE"
res1 = Cos (n3)
txtResult2.Text = res1
End If

If MDIForm1.opr = "T" Then
frmCalculate.fraTrig.Caption = "TAN OF ANGLE"
res1 = Tan(n3)
txtResult2.Text = res1
End If
End Sub
Private Sub Command4_Click()
Unload Me
MDIForm1.Show
End Sub
Private Sub Form_Resize()
Frame1.Left = (Me.Width - Frame1.Width)/ 2 - 50
Frame1.Top = (Me.Height - Frame1.Height)/ 2 - 230
End Sub

basic with a back and tool having fields employee number, employee name, marital status as to single or double

2009-12-19T01:13:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to connect visual basic with a back and tool having fields employee number, employee name, marital status as to single or double (use option buttons). Give the privileges to add, save, delete, modify and search the record. Give all the navigation facility to the user.

Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset

Private Sub cmdClear_Click()
'Call clear1
'cmdSave.Enabled = True
'Text1.SetFocus
Text1.Text = " "
Text2.Text = " "
Option1. Value = False
0ption2.Value = False
Text1.SetFocus
End Sub

Private Sub cmdDelete_Click()
a = MsgBox("Are you sure?", vbYesNo, "CONFORMATION ALERT")
If a = vbYes Then
con.Execute "delete from employee where empcode=" &
Text1.Text
MsgBox " Record deleted ...."
If rs.State = adStateOpen Then
rs.Close
End If
rs.Open "select * from employee", con, adOpenDynamic,
adLockBatchOptimistic
rs.MoveFirst
Call show1
End If
End Sub

Private Sub cmdFisrt_Click()
If rs.State = adStateOpen Then
rs.Close
End If
rs.0pen "select * from employee",con, adOpenDynamic,
adLockBatchOptimistic
rs.MoveFirst
Call show1
End Sub

Private Sub cmdLast_Click()
If rs.State = adStateOpen Then
rs.Close
End If

rs.Open "select *from employee",con, adOpenDynamic
rs.MoveLast
Call show1
End Sub

Private Sub cmdModify_Click()
If Option1.Value = True Then
marstatus = "Single"
End If
If Option2.Value = True Then
marstatus = "Double"
End If
con.Execute "update employee set empname=" & Text2.Text &
" ', marstatus=' " & marstatus & " ' where empcode=" & " ' where empcode=" &
Text1.Text
MsgBox "Record Modified.....",vbOKOnly, "Update"
End Sub

Private Sub cmdNext_Click()
If rs.State = adStateOpen Then
rs.Close
End If
rs.Open "select * from employee", con,adOpenDynamic,
adLockBatchOptimistic
rs.MoveNext
If rs.EOF = True Then
rs.MoveLast
MsgBox "End of File encountered",vbOKOnly,"eof "
End If
Call show1
End Sub
Private Sub cmdPrevious_Click()
If rs. State = adStateOpen Then
rs.Close
End If
rs.Open "select * from employee",con, adOpenDynamic,
adLockBatchOptimistic
rs.MovePrevious
If rs.BOF = True Then
rs.MoveFirst
MsgBox "Begining Of File encounter..", vbOKOnly, "BOF"
End If
Call show1
End Sub
Private Sub cmdSave_Click()
If Option1. Value = True Then
marstatus = "Single"
End If
If Option2. Value = True Then
marstatus = "Double"
End If
con.Execute "insert into employee values(" & Text1.Text & ", ' " & Text2. Text &" ', ' " & marstatus & " ')"
MsgBox " Record saved....",vbOKOnly, "Save"
rs. Close
rs.Open
'cmdSave. Enabled = False
End Sub

Private Sub Command9_Click()
Unload Me
End Sub

Private Sub Form_Load()
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=D:\adodb\connection.mdb;Persist Security Info=False"
If rs.State= adStateOpen Then
rs.Close
End If
rs.Open "select * from employee", con, adOpenDynamic,
adLockBatchOptimistic
If (rs.EOF= False And rs.BOF = False) Then
Call show1
'cmdSave. Enabled = False
End If
End Sub
Private Sub Form_Resize()
Frame1.Left = (Me.Width - Frame1.Width) / 2 - 50
Frame1.Top = (Me. Height - Frame1.Height) / 2 - 230
End Sub
Private Sub show1()
Text1.Text = rs! empcode
Text2.Text = rs! empname
If Trim (rs! marstatus) = "Single" Then
Option1.Value = True
Else
'If rs!marstatus = "Single" Then
Option2. Value = True
End If
End Sub

basic with a back end tool having fields roll number, name, address, marks, date of birth. Give the privileges to add,save,delete,modify and search

2009-12-19T01:08:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic with a back end tool having fields roll number, name, address, marks, date of birth. Give the privileges to add, save, delete, modify and search the records. Give all the navigation facilities to the user. Note: Use data control

Ans

Private Sub cmdAdd_Click()
add
Student. Recordset. AddNew
End Sub
Private Sub cmdFirst_Click()
Student. Recordset .MoveFirst
End Sub
Private Sub cmdLast_Click()
Student. Recordset .MoveLast
End Sub
Private Sub cmdNext_Click()
Student. Recordset.MoveNext
End Sub
Private Sub cmdPrevious_Click()
Student. Recordset.MovePrevious
End Sub
Private Sub cmdSave_Click()
save
Student. Recordset. Update
End Sub
Private Sub cmdModify_Click()
modify
Student. Recordset. Edit
End Sub
Private Sub cmdDelete_Click()
'delete
Student. Recordset. Delete
Student. Recordset. MoveFirst
End Sub

basic to Input an alphanumeric string and separate the characters and numbers.

2009-12-19T01:04:00.001-08:00

Draw flowchart, write an algorithm and program in visual basic to Input an alphanumeric string and separate the characters and numbers.

Ans:

Dim str__len, I As Integer
Dim str, dig As String
Private Sub CmdSep_Click()
str = txtString.Text
str__len = Len(str)
For I = 1 To str_len
st = Mid(str,I, 1)
If Asc(st) >= 65 Or Asc(st) >= 112 Then
alpha = alpha + st
Elself Asc(st) >= 48 Or Asc(st) <= 57 Then
dig = dig + st
End If
Next
txtAlpha. Text = alpha
txtDigit.Text = dig
End Sub

basic to Perform multiplication of two matrices.

2009-12-19T01:01:00.001-08:00

Draw flowchart, write an algorithm and program in visual basic to Perform multiplication of two matrices.

Dim m1(0 To 3) As Integer
Dim m2 (0 To 3) As Integer
Dim m3 (0 To 3) As Integer
Dim m4 (0 To 3) As Integer
Dim m5 (0 To 3) As Integer
Dim m6 (0 To 3) As Integer
Private Sub cmdEqual_Click()
For i = 0 To 3
m1(i) = CInt(txtm1(i).Text)
m2(i) = CInt (txtm2(i).Text)
Next
For j = 0 To 3
m3(j) = m1(0) * m2(j)
txtr1(j). Text = m3(j)
Next
For j = 0 To 3
m4(j) = m1(1) * m2(j)
txtr2(j) . Text = m4(j)
Next
For j = 0 To 3
m5(j) = m1(2) * m2(j)
txtr3(j).Text = m5(j)
Next
For j = 0 To 3
m6(j) = m1(3) * m2(j)
txtr4(j). Text = m6(j)
Next
End Sub

basic to Search an element from characters and as well as from numbers using binary search method.

2009-12-19T00:54:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to Search an element from characters and as well as from numbers using binary search method.

Dim skey As Integer
Dim low, high, middle As Integer
Dim found As Boolean

Dim skey1 As String
Dim low1, high1, middlel As Integer
Dim found1 As Boolean
Private Sub cmdNumSearch_Click()
Binary search for Numbers
low = 0
high = 5
found = False
skey = CInt(txtSearch.Text)
Do While found <> True And low <= high
middle = (high + low) / 2

If txtArr (middle). Text < skey Then
low = middle + 1
Elself txtArr(middle).Text > skey Then
high = middle - 1
Else
found = True
End If
Loop
If found = True Then
MsgBox "Element found at:" + CStr(middle + 1)
Else
MsgBox " element not found"
End If
End Sub
Private Sub cmdCharSearch_LostFocus()
For I = 0 To 5
txtArr (I).Text = Clear
Next
End Sub
Private Sub cmdCharSearch_Click()
low1 = 0
high1 = 5
found1 = False
skey1 = txtSearch.Text
Do While found1 <> True And low1 <= high1
middle1 = (high1 + low1) / 2
If txtArr (middle1).Text < skey1 Then
low1 = middle1 + 1
Elself txtArr(middle1).Text > skey1 Then
high1 = middle1 - 1
Else
found1 = True
End If
Loop
If found1 = True Then
MsgBox "Element Found At :" + CStr(CInt(middle1 + 1))
Else
MsgBox "Element Not Found"
End If
End Sub
Private Sub cmdNumSearch_LostFocus()
For I = 0 To 5
txtArr(I).Text = Clear
Next
End Sub

To Search A Character From An Array Using Sequential Search

2009-12-19T00:51:00.000-08:00

To Search A Character From An Array Using Sequential Search

Ans:

Dim SKEY As String
Dim FLAG As Boolean
Private Sub cmdSearch_Click()
SKEY = txtSearch. Text
For I = 0 To 5
If txtCArr(I).Text = SKEY Then
FLAG = True
Exit For
End If
Next
lblOutput1.Caption = Clear
If FLAG = True Then
lblOutput1.Caption = "The Element Is Found At " + CStr(I + 1) + " Position"
Else
lblOutput1. Caption = "ELEMENT NOT FOUND"
End If
End Sub
Private Sub cmdSearch_LostFocus()
For I = 0 To 5
txtCarr (I). Text = Clear
Next
End Sub

To Search A Number From An Array Using Sequential Search

2009-12-19T00:47:00.000-08:00

To Search A Number From An Array Using Sequential Search

Ans:

Dim SKEY As String
Dim FLAG As Boolean
Private Sub cmdSearch_Click()
SKEY = CInt(txtSearch.Text)
FLAG = False
For I = 0 To 5
If txtNarr(I).Text = SKEY Then
FLAG = True
Exit For
End If
Next
If FLAG = True Then
IblOutput1.Caption = "The Element Is Found At Position" CStr (I + 1)
Else
IblOutput1. Caption = "Element Is Not Found"
End If
End Sub
Private Sub cmdSearch_LostFocus ()
For I = 0 To 5
txtNarr(I).Text = Clear
Next
End Sub

To Sort Characters with The Help of Bubble Sort

2009-12-19T00:43:00.000-08:00

To Sort Characters with The Help of Bubble Sort

Ans :

Private sub cmdsort_LostFocus()
For I = 0 To 5
txtCarr(I)Text = Clear
Next
End Sub
Private Sub cmdSort_Click()
Dim I, J As Integer
Dim CArr (4) As String
For I = 0 To 4
CArr(I)= txtCarr(I).Text
Next
For I = 0 To 4
For J = 4 To I + 1 Step -1
If CArr (J) < CArr(J - 1) Then
X = CArr(J)
CArr (J) = CArr(J - 1)
CArr (J - 1) = X
End If
Next
Next
For I = 0 To 4
txtOutput(I).Text = CArr(I)
Next
End Sub

To sort Numbers with the help of Bubble Sort

2009-12-19T00:40:00.000-08:00

To sort Numbers with the help of Bubble Sort

Private Sub cmdSort_Click()
Dim I,J,arr(5) As Integer
For I = 0 To 4
arr(I) = CInt(txtarr(I))
Next
Logic To Sort
J = 0
For I = 0 To 4
For J = 4 To I + 1 Step -1
If arr (J) < arr (J - 1) Then
X = arr(J)
arr(J) = arr(J - 1)
arr(J - 1) = X
End If
Next
Next
For I = 0 To 4
txtOutput(I).Text = CStr(arr(I))
Next
End Sub
Private Sub cmdSort_LostFocus()
For I = 0 To 5
txtarr(I).Text = Clear
Next
End Sub

To Sort Numbers Using Linear Sort

2009-12-19T00:37:00.000-08:00

To Sort Numbers Using Linear Sort

Private Sub cmdSort_Click ()
Dim I, J, K, arr(4) As Integer
For I = 0 To 4
arr(I) = CInt(txtarr(I).Text)
Next
For I = 0 To 3
For J = I To 4
If arr(I) < arr(J) Then
X = arr(I)
arr(I) = arr(J)
arr(J) = X
End If
Next
Next
For I = 0 To 4
txtoutput (I) .Text = CStr (arr (I))
Next
End Sub
Private Sub cmdSort__LostFocus()
For I = 0 To 4
txtarr(I).Text = Clear
Next
End Sub

To Sort Characters Using Linear Sort

2009-12-19T00:29:00.000-08:00

To Sort Characters Using Linear Sort

Private Sub cmdSort_Click()
0 To 3
Dim I, J, K As Integer
Dim arr(4) As String
For I = 0 To 4
arr(I) = txtarr(I).Text
Next
For I = For J = I To 4
If CStr(arr(I)) < CStr(arr(J)) Then
X = arr(I)
arr(I) = arr(J)
arr(J) = X
End If
Next
Next
For I = 0 To 4
txtOutput(I).Text = arr(I)
Next
End Sub
Private Sub cmdSort_LostFocus ()
For I = 0 To 4
txtarr(I).Text = Clear
Next
End Sub

basic to Conduct an online competitive exam.

2009-12-19T00:19:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to Conduct an online competitive exam. The exam should contain any five questions. User will be given four choices as an answer. Give 10 marks for every correct answer and 0 for every wrong answer. Display summery of result at the end.

Q1 form
Public marks As Integer
Public f1, f2, f3, f4, f5 As Boolean
Private Sub cmdNext_Click()
If opt Float.Value = True Then
marks = merks + 10
f1 = True
Else
marks = marks + 0
f1 = False
End If
frmQ2 .Show
End Sub

Q2 Form
Private Sub Command1_Click()
If optDev.Value = True Then
frmQl.marks = frmQl.marks + 10
frmQl.f2 = True
Else
frmQl.marks = frmQl.marks + 0
frmQl.f2 = False
End If
frmQ3.Show
End Sub

Q3 Form
Private Sub cmdNext_Click()
If optFoxPro. Value = True Then
frmQ1. marks = frmQl.marks + 10
frmQl.f3 = True
Else
frmQ1. marks = frmQl.marks + 0
frmQ1.f3 = False
End If
frmQ4.Show
End Sub

Q4 Form
Private Sub cmdNext_Click()
If optVbgreen. Value = True Then
frmQ1.marks = frmQ1.marks + 10
frmQ1.f4 = True
Else
frmQ1. marks = frmQl. marks + 0
frmQ1.f4 = False
End If
frmQ5.Show
End Sub

Q5 Form
Private Sub cmdNext_Click()
If opt False. Value = True Then
frmQ1.marks = frmQ1.marks + 10
frmQ1.f5 = True
Else
frmQ1. marks = frmQ1.marks + 0
frmQ1.f5 = False
End If
frmResult.Show
End Sub

Result Form
Private Sub cmdTotal_Click().
If frmQ1. f1 = True Then
txtQ1.Text = "Correct"
Else
txtQ1.Text = "Wrong"
End If
If frmQl.f2 = True Then
txtQ2.Text = "Correct"
Else
txtQ2.Text = "Wrong"
End If
If frmQl.f3 = True Then
txtQ3.Text = "Correct"
Else
txtQ3.Text = "Wrong"
End If
If frmQl.f4 = True Then
txtQ4.Text = "Correct"
Else
txtQ4.Text = "Wrong"
End If
If frmQl.f5 = True Then
txtQ5.Text = "Correct"
Else
txtQ5.text = "Wrong"
txtMarkS.Text = frmQl.marks
End Sub
Private Sub cmdExit_Click()
End
End Sub

basic to input consumer number, consumer name,area urban,ruraly,month of billing,last reading,current reading andcalculate thebill amount

2009-12-19T00:01:00.001-08:00

Draw flowchart, write an algorithm and programin visual basic to input consumer number, consumer name, area (urban,ruraly, month of billing, last reading, current reading and calculate the bill amount according to the following conditions.

Household:
1 to 30 - 1.00Rs.
31 to 100 - 2.55Rs.
101 to 300 - 2.95Rs.
301 onwards - 4.55Rs.
Industrial:
1 to 1000 - 2.40Rs.
1001 to 1500 - 3.00Rs.
1501 onwards - 3.40Rs.
Non Household:
1 to 100 - 2.56RS.
101 to 200 - 4.10Rs.
201 onwards - 5.00Rs.
Urban water supply - 2.25 Rs.
Rural, water supply - 1.40 Rs .
Agriculture - 0.90Rs.
Rural Lighting - 1.70Rs.
Urban Lighting - 2.50Rs.
Poultry Farm - 0.90Rs.
Total Reading = Current Reading - Last Reading

Ans:

Dim c, r1, a, b, p As Integer

Private Sub Form_Load()
cboOptions.Addltem "HOUSEHOLD", 0
cboOptions. Addltem "NONHOUSEHOLD",1
cboOptions.Addltem " IDNUSTRIAL", 2
cboOptions.Addltem "URBAN WTAER SUPPLY", 3
cboOptions. Addltem "RURAL WATER SUPPLY", 4
cboOptions.Addltem "AGRICULTURE", 5
cboOptions.Addltem "RURAL LIGHTING", 6
cboOptions.Addltem "URBAN LIGHTING", 7
cboOptions.Addltem "POULTRY FARM", 8

End Sub

Private Sub cmdCalculate_Click ()
p2 = 0
t1 = cboOptions.Text
c = Clnt(txtCMR.Text) - CInt (txtLMR. Text)
If t1 = "HOUSEHOLD" Then for Household purpose
If c > 300 Then
r1 = c - 300
p = rl * 4.55
p2 = p + 798.5

End If

If c > 100 And c <= 300 Then
r1 = c - 100
p = r1 * 2.95
p2 = p + 208.5

End If
If c > 30 And c <= 100 Then
r1 = c - 30
p = r1 * 2.55
p2 = p + 30

End If
If c <= 30 Then
r1 = c - 0
p = r1 * 1
p2 = p

End If
Elself t1 = "NONHOUSEHOLD" Then for non household
If c > 200 Then
r1 = c - 200
p= r1 * 5
p2 = p + 660
End If
If c > 100 And c <= 200 Then
r1 = c - 100
p = r1 * 4.1
p2 = p + 250
End If
If c <= 100 Then
r1 = c - 0
p = r1 * 2.5
p2 = p
End If
Elself t1 = "IDNUSTRIAL" Then for Industrial
If c > 15000 Then
r1 = c - 15000
p = r1 * 3.4
p2 = p + 44400
End If
If c > 1000 And c <= 15000 Then
r1 = c - 1000
p = r1 * 3
p2 = p + 2400
End If
If c <= 1000 Then
r1 = c - 0
p = r1 * 2.4
p2 = p
End If
Elself t1 = "URBAN WTABR SUPPLY" Then
p2 = c * 2.25
Elself t1 = "RURAL WATER SUPPLY" Then
p2 = c * 1.4
Elself t1 = "AGRICULTURE" Then
p2 = c * 0.9
Elself t1 = "RURAL LIGHTING" Then
p2 = c * 1.7
Elself t1 = "URBAN LIGHTING" Then
p2 = c * 2.5
Else
p2 = c * 0.9
End If
txtTAmt.Text = CStr(p2)

End Sub
Private Sub cmdClear_Click()
txtName.Text = Clear
txtNumber.Text = Clear
txtMOB.Text = Clear
txtLMR.Text = Clear
txtCMR.Text = Clear
cboOptions. Text = Clear
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub

basic to Input telephone number, consumer name, address, area (rural urban),Number of calls.

2009-12-18T23:58:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to Input telephone number, consumer name, address, area (rural urban),Number of calls. Calculate the telephone bill by using following conditions: Urban

a) Rental 250
b) Free calls 150
c) 151 to 400 calls - 0.80 Rs.
d) 401 to 1000 calls - 1 Rs.
e) 1001 onwards - 1.20Rs.
Rural
a) Rental 180
b) Free calls 250
c) 251 to 450 calls - 0.60 Rs.
d) 451 to 500 calls - 0.80RS.
e) 501 to 1000 - lRs.
f) 1001 onwards - 1.20 Rs.

Ans :

Dim Ncall As Integer Private Sub Form Load ()
optRural.Enabled = False
optUrban.Enabled = False

End Sub

Private Sub optRural_Click()
Ncall = CInt(txtCalls.Text)
If Ncall <= 180 Then s = 180 Elself Ncall >= 251 And Ncall <= 450 Then s = Ncall * 0.6 * 180 Elself Ncall >= 451 And Ncall <= 500 Then s = Ncall * 0.8 * 180 Elself Ncall > 501 And Ncall <= 1000 Then s = Ncall * 1 * 180 Elself Ncall > 1000 Then s = Ncall * 1.2 * 180

End If
txtFcall.Text = 250 txtTamt.Text = s

End Sub
Private Sub optUrban_Click()
Ncall = 0

If Ncall <=150 Then s = 250 Elself Ncall >= 151 And Ncall <= 400 Then s = Ncall * 0.8 * 250 Elself Ncall >= 401 And Ncall <= 1000 Then s = Ncall * 1 * 250 Elself Ncall > 1000 Then S = Ncall * 1.2 * 250

End If
txtFcall.Text = 150 txtTamt. Text = s

End Sub
Private Sub txtCalls_LostFocus() optRural. Enabled = True
optUrban.Enabled = True

End Sub

basic to Arrange the given pairs of options and allow the user to match the pairs.

2009-12-18T23:54:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to Arrange the given pairs of options and allow the user to match the pairs. If user has selected the correct option then the result should be given by displaying green color, red color otherwise. Correct pairs are given below:

Sachin Tendulkar : Cricket V.Anand : Chess
Leander Pace : Tennis
Mike Tyson : Boxing -
Note: Use option buttons.

Ans :

Private Sub optChess_Click()
If optAnand.Value = True Then txtcolor.BackColor = vbGreen

Else
txtcolor.BackColor = vbRed

End If

End Sub
Private Sub optTennis_Click()
If optPace. Value = True Then
txtcolor.BackColor = vbGreen

Else
txtcolor.BackColor = vbRed

End If

End Sub
Private Sub optCricket_Click ()
If optSachin.Value = True Then
txtcolor.BackColor =

vbGreen

Else
txtcolor.BackColor = vbRed

End If

End Sub
Private Sub optBoxing_Click()
If optTyson.Value = True Then
txtcolor.BackColor = vbGreen
Else
txtcolor.BackColor = vbRed

End If
End Sub

basic to Enter a date of birth from the user and calculate his age in days, months and years as on current date.

2009-12-18T23:48:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to Enter a date of birth from the user and calculate his age in days, months and years as on current date. Current date should be taken from the system.
Note: Use DTpicker control.

Ans:

Dim dob, curdate As Date
Dim d1, m1, y2, d2, m2, y1, d3, m3, y3 As Integer
Private Sub cmdAge_Click ()
dob = CDate(txtDob. Text) curdate = CDate(txtCDate.Text) d1 = Day(dob) m1 = Month (dob) y1 = Year (dob) d2 = Day(curdate)
y2 = Year(curdate)
If d1 > d2 Then d2 = d2 + 30 m2 = m2 - 1 End If
If m1 > m2 Then
m2 = m2 + 12 y2 = y2 - 1

End If

m3 = m2 - m1 Y3 = Y2 - Y1 d3 = d2 - d1 txtDay. Text = d3 txtMonth.Text = m3 txtYear. Text = y3 End Sub
Private Sub txtCDate_GotFocus ()
txtCDate. Text = Date

End Sub

Private Sub txtDob_Vali date (Cancel As Boolean)
If IsDate(txtDob.Text) = False Then MsgBox "Enter The Valid date" txtDob. Text = Clear txtDob.SetFocus

End If

End Sub

basic to Generate a stopwatch for 10 minutes. Note: Use timer control.

2009-12-18T23:45:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to Generate a stopwatch for 10 minutes. Note: Use timer control.

Ans:

Dim sec, min As Integer
Private Sub Timer1_Timer () sec = sec + 1 If sec = 60 Then sec = 0 min = min + 1
If min = 10 Then
MsgBox "10 minutes over" Timer1.Enabled = False

End If

End If

End Sub

basic to enter a decimal number from the user and convert it into equivalent binary number.

2009-12-18T23:41:00.000-08:00

Draw flowchart, write and algorithm and program in visual basic to enter a decimal number from the user and convert it into equivalent binary number.
From should be designed in such a way that all the controls should be located centrally in every size of the form.

Ans

Dim t As Integer
Dim d, num, sum As Single
Private Sub cmdClear_Click()
txtBinary. Text = Clear txtValue .Text = Clear

End Sub
'Logic To Convert Decimal To Binary Private Sub cmdConvert_Click()
t = 1
sum =0
num = CInt(txtValue.Text)
n = num
While Not num = 0 d = num Mod 2 sum = sum + (d * t)
t = t * 10
num = num \ 2
Wend
txtBinary.Text = CStr(sum)
End Sub

basic to Input at least four digit number from the user and print the addition of all the digit of given number.

2009-12-18T23:39:00.001-08:00

Draw flowchart, write an algorithm and program in visual basic to Input at least four digit number from the user and print the addition of all the digit of given number.
From should be designed in such a way that all the controls should be located centrally in every size of the form.

Ans:

Dim r, I, num, sum As Integer Dim rev As String
Private Sub cmdReverse_Click() sum = 0 num = CInt(txtnumber.Text)
For I =0 To 4
r = num Mod 10 num = num / 10
rev = rev + Str(r)
sum = sum + r
Next txtReverse.Text = rev
txtSum.Text = sum
End Sub

basic to generate a thermometer. The thermometer should be displayed vertically in vertical scroll bar.

2009-12-18T23:34:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to generate a thermometer. The thermometer should be displayed vertically in vertical scroll bar. Initially Celsius label should display 0 and Fahrenheit 32.If the user scroll the scroll bar upward then the temperature should be displayed in Celsius and Fahrenheit in the corresponding labels increased by 1. Celsius= (Fahrenheit-32)*5/9

Ans :
Dim tempf, tempc As Integer Private Sub cmdClear_Click() Logic for clearing text boxes IblFah. Caption = Clear
IblCel.Caption = Clear

End Sub
Private Sub cmdExit_click()
unload Me

End Sub
Private Sub Form__Load() VscTemp.Value = 32 IblFah.Caption = VscTemp.Value IblCel.Caption = 0

End Sub
Private Sub VscTemp_Change() tempf = CInt(VscTemp.Value) IblFah.Caption = CStr(tempf) tempc = ((tempf - 32) * 5 / 9) IblCel .Caption = CStr (tempc)
End Sub

basic to input the employee number, employee name,designation,basic salary and grade from the user and calculate the bonus according to the following.

2009-12-18T23:30:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to input the employee number, employee name,designation,basic salary and grade from the user and calculate the bonus according to the following. If grade is B then bonus will be 7000 From should be designed in such a way that all the controls should be located centrally in every size of the form.

Ans :

Dim bon, sal As Integer Private Sub cmdCalculate_Click() Logic for calculating the salary/bonus
If optA.Value = True Then bon = 1000

Elself optB.Value = True Then bon = 7000

Else bon = 12000

End If txtBonus. Text = CStr (bon) txtSal.Text = CStr(sal + bon) End Sub

basic to input the units in foot and convert it into meter, inches, centimeters and millimeters.

2009-12-18T23:00:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to input the units in foot and convert it into meter, inches, centimeters and millimeters. Form should be designed in such a way that all the controls should be located centrally is every size of the form. Meter=foot*0.305 Inch=foot*12 Centimeter=foot*30.48 Millimeter=foot*304.8 From should be designed in such a way that all the controls should be located centrally in every size of the form.

Ans:

Dim f As Single Logic for Calculation Part Private Sub cmdCalculate_Click() f = CSng(txtFoot.Text) txtMtr.Text = CStr(f * 0.305) txtlnch.Text = CStr(f * 12) txtCenti.Text = CStr(f * 30.48) txtMilli.Text = CStr(f * 304.8)

End Sub
'Logic To Clear the text boxes Private Sub cmdClear_Click() txtFoot.Text = Clear txtlnch.Text = Clear txtMilli.Text = Clear txtMtr.Text = Clear txtCenti.Text = Clear

End Sub

basic to input the ASCII values from the user and decide whether the given character is a capital letter, small letter, numeric value or specialsymbol

2009-12-18T22:57:00.000-08:00

Draw flowchart, write an algorithm and program in visual basic to input the ASCII values from the user and decide whether the given character is a capital letter, small letter, numeric value or special symbol. From should be designed in such a way that all the controls should be located centrally in every size of the form.

Ans:
Private Sub cmdClear_Click() txtOutput.Text = Clear txtString.Text = Clear txtString.SetFocus
End Sub
'Logic To Verify Through Ascii Values

Private Sub cmdVerify_Click () If (Asc (txtString.Text) >= 48 And Asc (txtString.Text) <= 57) Then txtOutput.Text = " Digit" Elself (Asc(txtString.Text) >= 65 And Asc(txtString.Text) <= 90) Then txtOutput.Text = "Capital Letter" Elself (Asc(txtString.Text) >= 97 And Asc(txtString.Text) <= 122) Then txtOutput.Text = "Small Letter" Else txtOutput. Text = "Special Symbol"
End If End Sub

Creating Runtime Data Reports

2009-10-12T08:01:00.000-07:00

Private Sub Combo1_Click()
If Combo1.Text = "OBC" Then
DataReport1.Show
ElseIf Combo1.Text = "SC" Then
DataReport2.Show
Else
DataReport3.Show
End If
End Sub

User Control ,Creating OCX File in VB, Adding OCX to Components .

2009-10-12T07:11:00.000-07:00

Dim a, b
Dim sy

Private Sub cmdequal_Click()
b = Val(Text1.Text)
Text1.Text = Empty
If sy = "+" Then
Text1.Text = a + b
ElseIf sy = "-" Then
Text1.Text = a - b
ElseIf sy = "*" Then
Text1.Text = a * b
Else
Text1.Text = a / b
End If
End Sub

Private Sub cmdnums_Click(Index As Integer)
Text1.Text = Text1.Text & cmdnums(Index).Caption
End Sub

Private Sub cmdop_Click(Index As Integer)
a = Val(Text1.Text)
sy = cmdop(Index).Caption
Text1.Text = Empty
End Sub

Adodc.Recordset Connectivity

2009-07-12T10:24:00.000-07:00

Private Sub add_Click()

Adodc1.Recordset.AddNew

End Sub

Private Sub delete_Click()

Adodc1.Recordset.delete

End Sub

Private Sub last_Click()

Adodc1.Recordset.MoveLast

End Sub

Private Sub modify_Click()

Adodc1.Recordset.EditMode

End Sub

Private Sub next_Click()

Adodc1.Recordset.MoveNext

End Sub

Private Sub previous_Click()

Adodc1.Recordset.MovePrevious

End Sub

Private Sub save_Click()

Adodc1.Recordset.save

End Sub

List in memory

2009-02-07T04:10:00.000-08:00

struct node
{
int x;
struct node *next;
};

int main()
{
/* This won't change, or we would lose the list in memory */
struct node *root;
/* This will point to each node as it traverses the list */
struct node *conductor;

root = malloc( sizeof(struct node) );
root->next = 0;
root->x = 12;
conductor = root;
if ( conductor != 0 ) {
while ( conductor->next != 0)
{
conductor = conductor->next;
}
}
/* Creates a node at the end of the list */
conductor->next = malloc( sizeof(struct node) );

conductor = conductor->next;

if ( conductor == 0 )
{
printf( "Out of memory" );
return 0;
}
/* initialize the new memory */
conductor->next = 0;
conductor->x = 42;

return 0;
}

Show the 'File Open' Common Dialog via API calls

2009-02-04T06:47:00.000-08:00

To display a file open common dialog use the following routine (an example routine can be found at the bottom of this post):

Option Explicit

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long

Private Type OpenFileName
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

'Purpose     :  Allows the user to select a file name from a local or network directory.
'Inputs      :  sInitDir            The initial directory of the file dialog.
'               sFileFilters        A file filter string, with the following format:
'                                   eg. "Excel Files;*.xls|Text Files;*.txt|Word Files;*.doc"
'               [sTitle]            The dialog title
'               [lParentHwnd]       The handle to the parent dialog that is calling this function.
'Outputs     :  Returns the selected path and file name or a zero length string if the user pressed cancel


Function BrowseForFile(sInitDir As String, Optional ByVal sFileFilters As String, Optional sTitle As String = "Open File", Optional lParentHwnd As Long) As String
    Dim tFileBrowse As OpenFileName
    Const clMaxLen As Long = 254
   
    tFileBrowse.lStructSize = Len(tFileBrowse)
   
    'Replace friendly deliminators with nulls
    sFileFilters = Replace(sFileFilters, "|", vbNullChar)
    sFileFilters = Replace(sFileFilters, ";", vbNullChar)
    If Right$(sFileFilters, 1) <> vbNullChar Then
        'Add final delimiter
        sFileFilters = sFileFilters & vbNullChar
    End If
   
    'Select a filter
    tFileBrowse.lpstrFilter = sFileFilters & "All Files (*.*)" & vbNullChar & "*.*" & vbNullChar
    'create a buffer for the file
    tFileBrowse.lpstrFile = String(clMaxLen, " ")
    'set the maximum length of a returned file
    tFileBrowse.nMaxFile = clMaxLen + 1
    'Create a buffer for the file title
    tFileBrowse.lpstrFileTitle = Space$(clMaxLen)
    'Set the maximum length of a returned file title
    tFileBrowse.nMaxFileTitle = clMaxLen + 1
    'Set the initial directory
    tFileBrowse.lpstrInitialDir = sInitDir
    'Set the parent handle
    tFileBrowse.hwndOwner = lParentHwnd
    'Set the title
    tFileBrowse.lpstrTitle = sTitle
   
    'No flags
    tFileBrowse.flags = 0

    'Show the dialog
    If GetOpenFileName(tFileBrowse) Then
        BrowseForFile = Trim$(tFileBrowse.lpstrFile)
        If Right$(BrowseForFile, 1) = vbNullChar Then
            'Remove trailing null
            BrowseForFile = Left$(BrowseForFile, Len(BrowseForFile) - 1)
        End If
    End If
End Function

Sub Test()
    BrowseForFile "c:\", "Excel File (*.xls);*.xls", "Open Workbook"
End Sub

Show the 'Choose a Color' Common Dialog

2009-02-04T06:46:00.000-08:00

Option Explicit
Private Declare Function ChooseColorA Lib "comdlg32.dll" (pChoosecolor As tChooseColor) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long

Private Type tChooseColor
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

'Purpose     :  Shows the Choose Color Dialog
'Inputs      :  N/A
'Outputs     :  Returns -1 if the user pressed cancel, else returns the selected color


Function ShowColor() As Long
    Dim tColor As tChooseColor
    Dim Custcolor(16) As Long
    Dim lReturn As Long, lThisColor As Long
    Dim abytCustomColors(0 To 16 * 4 - 1) As Byte
   
    For lThisColor = LBound(abytCustomColors) To UBound(abytCustomColors)
        abytCustomColors(lThisColor) = 0
    Next

    tColor.lStructSize = Len(tColor)
    tColor.hwndOwner = GetActiveWindow        'or Me.hwnd in VB
    tColor.hInstance = 1       'or App.hInstance in VB
    'Convert the custom colors to Unicode
    tColor.lpCustColors = StrConv(abytCustomColors, vbUnicode)
    tColor.flags = 0

    'Show the dialog
    If ChooseColorA(tColor) <> 0 Then
        ShowColor = tColor.rgbResult
    Else
        ShowColor = -1
    End If
End Function

Displaying The Windows Colour Dialog

2009-02-04T06:45:00.002-08:00

'Declare various Types, ENums and Functions.
Private Type udtCHOOSECOLOR
    lStructSize As Long
    hWndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    Flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Public Enum ColorDialogFlags
    UseInitialColor = &H1
    ShowCustomColorsOnLoad = &H2
    DisableCustomColors = &H4
    ShowHelp = &H8
    OnlySolidColors = &H80
    AllowAnyColor = &H100
    Default = &H1 Or &H100
End Enum

Private CDColor As udtCHOOSECOLOR

Private Declare Function ChooseColor Lib "comdlg32.dll" _
 Alias "ChooseColorA" (pChoosecolor As udtCHOOSECOLOR) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long


Public Function GetColor(ByVal T_hWnd As Long, ByVal Flags As ColorDialogFlags, _
 Optional ByVal InitialColor As Long) As Long
    'Dimension a variable.
    Dim CustColors(0 To 15) As Long
   
    'Set up the colour configuration.
    For I = 0 To 15
        CustColors(I) = vbWhite
    Next
    CDColor.Flags = Flags
    CDColor.hWndOwner = T_hWnd
    CDColor.hInstance = App.hInstance
    CDColor.lpCustColors = VarPtr(CustColors(0))
    CDColor.lStructSize = Len(CDColor)
    CDColor.rgbResult = InitialColor
    lngResult = ChooseColor(CDColor)
   
    'Get the colour that is selected.
    If lngResult = 1 And CommDlgExtendedError = 0 Then
        GetColor = CDColor.rgbResult
    Else
        GetColor = -1
    End If
End Function

Displaying The Search For Directory Dialog

2009-02-04T06:45:00.001-08:00

Private Declare Function SHBrowseForFolder _
 Lib "shell32" (lpbi As BrowseInfo) As Long

Private Declare Function SHGetPathFromIDList _
 Lib "shell32" (ByVal pidList As Long, _
 ByVal lpBuffer As String) As Long

Private Declare Function lstrcat Lib "kernel32" _
 Alias "lstrcatA" (ByVal lpString1 As String, ByVal _
 lpString2 As String) As Long

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

'Wrapper Function.
Private Sub DirBox(Msg As String, Directory As String)

    'Dimension some variables.
    Dim lpIDList As Long
    Dim sBuffer As String
    Dim szTitle As String
    Dim tBrowseInfo As BrowseInfo
   
    'Set the message displayed on the dialog.
    szTitle = Msg
   
    'Set up the Type.
    With tBrowseInfo
       .hWndOwner = Me.hWnd
       .lpszTitle = lstrcat(szTitle, "")
       .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
    End With
   
    'Show the dialog box.
    lpIDList = SHBrowseForFolder(tBrowseInfo)

    'Process the data returned.
    If (lpIDList) Then
       sBuffer = Space(MAX_PATH)
       SHGetPathFromIDList lpIDList, sBuffer
       sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
       Directory = sBuffer
    End If

End Sub

Displaying The Common Save Dialog

2009-02-04T06:43:00.001-08:00

'The API Function.
Public Declare Function GetSaveFileName Lib "comdlg32.dll" _
 Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

'Now come some Types.
Public Enum GFNFlags
    OFN_ALLOWMULTISELECT = &H200
    OFN_CREATEPROMPT = &H2000
    OFN_EXPLORER = &H80000
    OFN_FILEMUSTEXIST = &H1000
    OFN_HIDEREADONLY = &H4
    OFN_LONGNAMES = &H200000
    OFN_NOCHANGEDIR = &H8
    OFN_NODEREFERENCELINKS = &H100000
    OFN_NOLONGNAMES = &H40000
    OFN_NONETWORKBUTTON = &H20000
    OFN_NOREADONLYRETURN = &H8000
    OFN_NOTESTFILECREATE = &H10000
    OFN_NOVALIDATE = &H100
    OFN_OVERWRITEPROMPT = &H2
    OFN_PATHMUSTEXIST = &H800
    OFN_READONLY = &H1
End Enum

Type OPENFILENAME
   lStructSize As Long
   hwndOwner As Long
   hInstance As Long
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   lpstrFile As String
   nMaxFile As Long
   lpstrFileTitle As String
   nMaxFileTitle As Long
   lpstrInitialDir As String
   lpstrTitle As String
   Flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
End Type

'This is the wrapper Function.
Public Function SaveDialog(ByVal OwnerhWnd As Long, _
 ByVal Filters As String, ByVal FilterIndex As Long, _
 ByVal FNameLength As Long, _
 Optional ByVal InitFolder As String = "", _
 Optional ByVal InitFileName As String = "", _
 Optional ByVal dlgTitle As String = "", _
 Optional ByVal Flags As GFNFlags = 0) As String
    'Dimension some variables.
    Dim GFN As OPENFILENAME
   
    'Sort out some of the Type we will pass.
    GFN.lStructSize = Len(GFN)
    GFN.hwndOwner = OwnerhWnd
    GFN.hInstance = App.hInstance
   
    'Sort out the filters.
    For I = 1 To Len(Filters)
        If Mid$(Filters, I, 1) = "|" Then
            Filters = Left$(Filters, I - 1) & Chr$(0) & _
             Right$(Filters, Len(Filters) - I)
        End If
    Next
   
    'Finish setting up the Type.
    GFN.lpstrFilter = Filters
    GFN.nFilterIndex = FilterIndex
    GFN.lpstrFile = InitFileName & String$(FNameLength - Len(InitFileName), Chr$(0))
    GFN.nMaxFile = FNameLength
    GFN.lpstrFileTitle = String$(FNameLength, Chr$(0))
    GFN.nMaxFileTitle = FNameLength
    GFN.lpstrInitialDir = InitFolder
    GFN.lpstrTitle = dlgTitle
    GFN.Flags = Flags
   
    'Get and return the filename.
    If GetSaveFileName(GFN) >= 1 Then
        SaveDialog = GFN.lpstrFile
    Else
        SaveDialog = Chr$(0)
    End If

End Function

2009-02-04T06:37:00.000-08:00

'The API Function.
Public Declare Function GetOpenFileName Lib "comdlg32.dll" _
 Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

'Now come some Types.
Public Enum GFNFlags
    OFN_ALLOWMULTISELECT = &H200
    OFN_CREATEPROMPT = &H2000
    OFN_EXPLORER = &H80000
    OFN_FILEMUSTEXIST = &H1000
    OFN_HIDEREADONLY = &H4
    OFN_LONGNAMES = &H200000
    OFN_NOCHANGEDIR = &H8
    OFN_NODEREFERENCELINKS = &H100000
    OFN_NOLONGNAMES = &H40000
    OFN_NONETWORKBUTTON = &H20000
    OFN_NOREADONLYRETURN = &H8000
    OFN_NOTESTFILECREATE = &H10000
    OFN_NOVALIDATE = &H100
    OFN_OVERWRITEPROMPT = &H2
    OFN_PATHMUSTEXIST = &H800
    OFN_READONLY = &H1
End Enum

Type OPENFILENAME
   lStructSize As Long
   hwndOwner As Long
   hInstance As Long
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   lpstrFile As String
   nMaxFile As Long
   lpstrFileTitle As String
   nMaxFileTitle As Long
   lpstrInitialDir As String
   lpstrTitle As String
   Flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
End Type

'This is the wrapper Function.
Public Function OpenDialog(ByVal OwnerhWnd As Long, _
 ByVal Filters As String, ByVal FilterIndex As Long, _
 ByVal FNameLength As Long, _
 Optional ByVal InitFolder As String = "", _
 Optional ByVal InitFileName As String = "", _
 Optional ByVal dlgTitle As String = "", _
 Optional ByVal Flags As GFNFlags = 0) As String
    'Dimension some variables.
    Dim GFN As OPENFILENAME
   
    'Sort out some of the Type we will pass.
    GFN.lStructSize = Len(GFN)
    GFN.hwndOwner = OwnerhWnd
    GFN.hInstance = App.hInstance
   
    'Sort out the filters.
    For I = 1 To Len(Filters)
        If Mid$(Filters, I, 1) = "|" Then
            Filters = Left$(Filters, I - 1) & Chr$(0) & _
             Right$(Filters, Len(Filters) - I)
        End If
    Next
   
    'Finish setting up the Type.
    GFN.lpstrFilter = Filters
    GFN.nFilterIndex = FilterIndex
    GFN.lpstrFile = InitFileName & String$(FNameLength - Len(InitFileName), Chr$(0))
    GFN.nMaxFile = FNameLength
    GFN.lpstrFileTitle = String$(FNameLength, Chr$(0))
    GFN.nMaxFileTitle = FNameLength
    GFN.lpstrInitialDir = InitFolder
    GFN.lpstrTitle = dlgTitle
    GFN.Flags = Flags
   
    'Get and return the filename.
    If GetOpenFileName(GFN) >= 1 Then
        OpenDialog = GFN.lpstrFile
    Else
        OpenDialog = Chr$(0)
    End If

End Function

Send the text in a range to a word document

2009-02-04T02:46:00.000-08:00

'Purpose : Sends the text in a range to a word application
'Inputs : rngSelection The range to send to a word document
'Outputs : Returns True on success.

Function WordSendRangeTo(rngSelection As Object, Optional sSaveToFile As String, Optional bShowWord As Boolean = False) As Boolean
Dim oWordApp As Object 'Early bound type = Word.Application
Dim oNewDoc As Object 'Early bound type = Word.Document
Dim oWordRange As Object 'Early bound type = Word.Range
Dim avVaules As Variant, vCell As Variant, sText As String

On Error GoTo ErrFailed
'Build up text to send to word document
avVaules = rngSelection.Value
For Each vCell In avVaules
sText = sText & vCell & " "
Next
sText = Trim$(sText)

'Create word objects
Set oWordApp = CreateObject("Word.Application")
Set oNewDoc = oWordApp.Documents.Add
Set oWordRange = oNewDoc.Words(1)

'Send text to word document
With oWordRange
.Text = sText
On Error Resume Next
Set .Font = rngSelection.Font
End With
On Error GoTo ErrFailed

'Save Document
If Len(sSaveToFile) Then
oNewDoc.SaveAs sSaveToFile
End If

If bShowWord Then
'Show Word
oWordApp.Visible = True
oWordApp.WindowState = 1 'wdWindowStateMaximize
Else
'Quit word
oWordApp.Quit
End If

WordSendRangeTo = True
GoTo ExitSub

ErrFailed:
'Error occurred
WordSendRangeTo = False

ExitSub:
'De-reference objects
Set oWordApp = Nothing
Set oNewDoc = Nothing
Set oWordRange = Nothing
End Function

'Demonstration routine
Sub Test()
WordSendRangeTo Selection, "C:\test.doc"
End Sub

Start, Stop and Pause NT Services

2009-02-04T02:45:00.000-08:00

Option Explicit

Public Enum eServiceState
essStopService
essStartService
essPauseService
End Enum

Private Declare Function CloseServiceHandle Lib "advapi32.dll" (ByVal hSCObject As Long) As Long
Private Declare Function ControlService Lib "advapi32.dll" (ByVal lHwndService As Long, ByVal dwControl As Long, lpServiceStatus As SERVICE_STATUS) As Long
Private Declare Function OpenSCManager Lib "advapi32.dll" Alias "OpenSCManagerA" (ByVal lpMachineName As String, ByVal lpDatabaseName As String, ByVal dwDesiredAccess As Long) As Long
Private Declare Function OpenService Lib "advapi32.dll" Alias "OpenServiceA" (ByVal hSCManager As Long, ByVal lpServiceName As String, ByVal dwDesiredAccess As Long) As Long
Private Declare Function QueryServiceStatus Lib "advapi32.dll" (ByVal lHwndService As Long, lpServiceStatus As SERVICE_STATUS) As Long
Private Declare Function StartService Lib "advapi32.dll" Alias "StartServiceA" (ByVal lHwndService As Long, ByVal dwNumServiceArgs As Long, ByVal lpServiceArgVectors As Long) As Long

Private Const SERVICES_ACTIVE_DATABASE = "ServicesActive"
Private Const SERVICE_CONTROL_STOP = &H1
Private Const SERVICE_CONTROL_PAUSE = &H2
Private Const SERVICE_STOPPED = &H1
Private Const SERVICE_START_PENDING = &H2
Private Const SERVICE_STOP_PENDING = &H3
Private Const SERVICE_RUNNING = &H4
Private Const SERVICE_CONTINUE_PENDING = &H5
Private Const SERVICE_PAUSE_PENDING = &H6
Private Const SERVICE_PAUSED = &H7
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SC_MANAGER_CONNECT = &H1
Private Const SC_MANAGER_CREATE_SERVICE = &H2
Private Const SC_MANAGER_ENUMERATE_SERVICE = &H4
Private Const SC_MANAGER_LOCK = &H8
Private Const SC_MANAGER_QUERY_LOCK_STATUS = &H10
Private Const SC_MANAGER_MODIFY_BOOT_CONFIG = &H20
Private Const SC_MANAGER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SC_MANAGER_CONNECT Or SC_MANAGER_CREATE_SERVICE Or SC_MANAGER_ENUMERATE_SERVICE Or SC_MANAGER_LOCK Or SC_MANAGER_QUERY_LOCK_STATUS Or SC_MANAGER_MODIFY_BOOT_CONFIG)
Private Const SERVICE_QUERY_CONFIG = &H1
Private Const SERVICE_CHANGE_CONFIG = &H2
Private Const SERVICE_QUERY_STATUS = &H4
Private Const SERVICE_ENUMERATE_DEPENDENTS = &H8
Private Const SERVICE_START = &H10
Private Const SERVICE_STOP = &H20
Private Const SERVICE_PAUSE_CONTINUE = &H40
Private Const SERVICE_INTERROGATE = &H80
Private Const SERVICE_USER_DEFINED_CONTROL = &H100
Private Const SERVICE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SERVICE_QUERY_CONFIG Or SERVICE_CHANGE_CONFIG Or SERVICE_QUERY_STATUS Or SERVICE_ENUMERATE_DEPENDENTS Or SERVICE_START Or SERVICE_STOP Or SERVICE_PAUSE_CONTINUE Or SERVICE_INTERROGATE Or SERVICE_USER_DEFINED_CONTROL)

Private Type SERVICE_STATUS
dwServiceType As Long
dwCurrentState As Long
dwControlsAccepted As Long
dwWin32ExitCode As Long
dwServiceSpecificExitCode As Long
dwCheckPoint As Long
dwWaitHint As Long
End Type

'Purpose : Returns the status of a NT Service
'Inputs : sServiceName The name of the service to test
' [sComputerName] The name of the machine to test the service status on.
' If unspecified uses the local machine
'Outputs : Returns a English description of the service status

Public Function ServiceStatus(sServiceName As String, Optional sComputerName As String) As String
Dim tServiceStat As SERVICE_STATUS
Dim lHwndSManager As Long
Dim lHwndService As Long
Dim hServiceStatus As Long

'Check the input data
If InStr(1, sServiceName, " ") Then
Debug.Print "Service names cannot contain spaces. Use the 'Service Name' of the service, not the 'Display Name'"
Exit Function
End If

ServiceStatus = ""
'Open the service manager
lHwndSManager = OpenSCManager(sComputerName, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS)
If lHwndSManager <> 0 Then
'Open the service
lHwndService = OpenService(lHwndSManager, sServiceName, SERVICE_ALL_ACCESS)
If lHwndService <> 0 Then
'Query the service
hServiceStatus = QueryServiceStatus(lHwndService, tServiceStat)
If hServiceStatus <> 0 Then
Select Case tServiceStat.dwCurrentState
Case SERVICE_STOPPED
ServiceStatus = "Stopped"
Case SERVICE_START_PENDING
ServiceStatus = "Start Pending"
Case SERVICE_STOP_PENDING
ServiceStatus = "Stop Pending"
Case SERVICE_RUNNING
ServiceStatus = "Running"
Case SERVICE_CONTINUE_PENDING
ServiceStatus = "Coninue Pending"
Case SERVICE_PAUSE_PENDING
ServiceStatus = "Pause Pending"
Case SERVICE_PAUSED
ServiceStatus = "Paused"
End Select
End If
'Close the service
CloseServiceHandle lHwndService
End If
'Close the service mananger
CloseServiceHandle lHwndSManager
End If
End Function

'Purpose : Changes the state of an NT Service
'Inputs : sServiceName The name of the service to test
' [sComputerName] The name of the machine to test the service status on.
' If unspecified uses the local machine
'Outputs : N/A

Public Function ServiceStateChange(sServiceName As String, eState As eServiceState, Optional sComputerName As String) As Boolean
Dim tServiceStatus As SERVICE_STATUS
Dim lHwndSManager As Long
Dim lHwndService As Long
Dim lRes As Long

'Check the input data
If InStr(1, sServiceName, " ") Then
Debug.Print "Service names cannot contain spaces. Use the 'Service Name' of the service, not the 'Display Name'"
ServiceStateChange = False
Exit Function
End If

'Open the service manager
lHwndSManager = OpenSCManager(sComputerName, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS)
If lHwndSManager <> 0 Then
'Open the service
lHwndService = OpenService(lHwndSManager, sServiceName, SERVICE_ALL_ACCESS)
If lHwndService <> 0 Then
Select Case eState
Case essPauseService
'Pause the service
lRes = ControlService(lHwndService, SERVICE_CONTROL_PAUSE, tServiceStatus)
Case essStartService
'Start the service
lRes = StartService(lHwndService, 0, 0)
Case essStopService
lRes = ControlService(lHwndService, SERVICE_CONTROL_STOP, tServiceStatus)
Case Else
Debug.Print "Invalid Service State"
Debug.Assert False
End Select

If lRes Then
'Success
ServiceStateChange = True
Else
'Failed
ServiceStateChange = False
Debug.Print "Error in ServiceStateChange: " & Err.LastDllError
Debug.Assert False
End If
CloseServiceHandle lHwndService
End If
CloseServiceHandle lHwndSManager
Else
Debug.Print "Failed to open service mananger!"
Debug.Assert False
ServiceStateChange = False
End If
End Function

'Demonstration routine using the "Windows Time" service
Sub Test()
Dim sStatus As String

sStatus = ServiceStatus("W32Time")
Debug.Print "Event Log is now " & sStatus

Call ServiceStateChange("W32Time", essStopService)
sStatus = ServiceStatus("W32Time")
Debug.Print "Event Log is now " & sStatus

Call ServiceStateChange("W32Time", essStartService)
sStatus = ServiceStatus("Eventlog")
Debug.Print "Event Log is now " & sStatus
End Sub

Determining the system folder locations

2009-02-04T02:43:00.000-08:00

Option Explicit

Public Enum epPath
    CSIDL_DESKTOP = &H0
    CSIDL_INTERNET = &H1
    CSIDL_PROGRAMS = &H2
    CSIDL_CONTROLS = &H3
    CSIDL_PRINTERS = &H4
    CSIDL_PERSONAL = &H5
    CSIDL_FAVORITES = &H6
    CSIDL_STARTUP = &H7
    CSIDL_RECENT = &H8
    CSIDL_SENDTO = &H9
    CSIDL_BITBUCKET = &HA
    CSIDL_STARTMENU = &HB
    CSIDL_DESKTOPDIRECTORY = &H10
    CSIDL_DRIVES = &H11
    CSIDL_NETWORK = &H12
    CSIDL_NETHOOD = &H13
    CSIDL_FONTS = &H14
    CSIDL_TEMPLATES = &H15
    CSIDL_COMMON_STARTMENU = &H16
    CSIDL_COMMON_PROGRAMS = &H17
    CSIDL_COMMON_STARTUP = &H18
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19
    CSIDL_APPDATA = &H1A
    CSIDL_PRINTHOOD = &H1B
    CSIDL_LOCAL_APPDATA = &H1C
    CSIDL_ALTSTARTUP = &H1D
    CSIDL_COMMON_ALTSTARTUP = &H1E
    CSIDL_COMMON_FAVORITES = &H1F
    CSIDL_INTERNET_CACHE = &H20
    CSIDL_COOKIES = &H21
    CSIDL_HISTORY = &H22
    CSIDL_COMMON_APPDATA = &H23
    CSIDL_WINDOWS = &H24
    CSIDL_SYSTEM = &H25
    CSIDL_PROGRAM_FILES = &H26
    CSIDL_MYPICTURES = &H27
    CSIDL_PROFILE = &H28
    CSIDL_SYSTEMX86 = &H29
    CSIDL_PROGRAM_FILESX86 = &H2A
    CSIDL_PROGRAM_FILES_COMMON = &H2B
    CSIDL_PROGRAM_FILES_COMMONX86 = &H2C
    CSIDL_COMMON_TEMPLATES = &H2D
    CSIDL_COMMON_DOCUMENTS = &H2E
    CSIDL_COMMON_ADMINTOOLS = &H2F
    CSIDL_ADMINTOOLS = &H30
    CSIDL_FLAG_CREATE = &H8000&
    CSIDL_FLAG_DONT_VERIFY = &H4000
    CSIDL_FLAG_MASK = &HFF00
End Enum


Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

Private Type SHITEMID
    CB As Long
    AbID As Byte
End Type

Private Type ITEMIDLIST
    Mkid As SHITEMID
End Type

Public Type SpecialFolder
    FolderPath As String
    FolderType As epPath
End Type

'Purpose     :  Returns an array of special folders
'Inputs      :
'Outputs     :  Returns an array of the special folders.


Function GetAllSpecialFolders() As SpecialFolder()
    Dim lThisFolder As Long, lNumFolders As Long
    Dim sFolderPath As String
    Dim resultArray() As SpecialFolder
   
    Const clMaxFolders As Long = 255
   
    On Error GoTo ErrFailed
    Erase resultArray
    'Return All Folders
    ReDim resultArray(1 To clMaxFolders)
    For lThisFolder = 0 To clMaxFolders
        sFolderPath = UCase$(GetSpecialFolder(lThisFolder))
        If Len(sFolderPath) Then
            lNumFolders = lNumFolders + 1
            resultArray(lNumFolders).FolderPath = sFolderPath
            resultArray(lNumFolders).FolderType = lThisFolder
        End If
    Next
   
    If lNumFolders Then
        ReDim Preserve resultArray(1 To lNumFolders)
        GetAllSpecialFolders = resultArray
    Else
        GetAllSpecialFolders = Empty
    End If
   
    Exit Function
ErrFailed:
    GetAllSpecialFolders = Empty
End Function

Function GetSpecialFolder(eFolderID As epPath) As String
    Dim tRetVal As Long, sBuffer As String
    Dim tIDL As ITEMIDLIST
    Const NO_ERROR = 0
   
    'Get the special folder
    tRetVal = SHGetSpecialFolderLocation(100&, eFolderID, tIDL)
    If tRetVal = NO_ERROR Then
        'Create a buffer
        sBuffer = Space$(512)
        'Get the path from the IDList
        tRetVal = SHGetPathFromIDList(ByVal tIDL.Mkid.CB, ByVal sBuffer)
        'Remove the unnecesarry chr$(0)'s
        GetSpecialFolder = Left$(sBuffer, InStr(1, sBuffer, vbNullChar) - 1)
        If Right$(GetSpecialFolder, 1) <> "\" And Len(GetSpecialFolder) > 0 Then
            GetSpecialFolder = GetSpecialFolder & "\"
        End If
    End If
End Function

'Demonstration routine
Sub Test()
    Dim atFolders() As SpecialFolder, tFolder As SpecialFolder, folder As Integer
    'Get all special folders
    atFolders = GetAllSpecialFolders()
    For folder = 1 To UBound(atFolders)
        tFolder = atFolders(folder)
        Debug.Print "Type: " & tFolder.FolderType & ". Path: " & tFolder.FolderPath
    Next

    'Get the start menu folder location
    Debug.Print GetSpecialFolder(CSIDL_STARTMENU)
End Sub

Preview an Access Database Report

2009-02-03T07:16:00.000-08:00

The function below can be used to preview a report created in MS Access.

'Purpose   :    Preview an Access Report from VB
'Inputs    :    sAccessDBPath           The path and filename of the access database containing the report to show
'               sReportName             The name of the report to show
'Outputs   :    Returns an empty string on success, else returns an error message.


Function AccessShowReport(sAccessDBPath As String, sReportName As String) As String
    Dim oAccess As Object 'Access.Application
   
    On Error GoTo ErrFailed
    AccessShowReport = ""
    'Create Access
    Set oAccess = CreateObject("Access.Application")
    'Open Database
    oAccess.OpenCurrentDatabase sAccessDBPath
    'Open report
    oAccess.DoCmd.OpenReport sReportName, 0 'acViewNormal
    'Show Access Report
    oAccess.Visible = True
    oAccess.CloseCurrentDatabase
    Set oAccess = Nothing
    Exit Function

ErrFailed:
    Debug.Print Err.Description
    Debug.Assert False
    AccessShowReport = Err.Description
    If oAccess Is Nothing = False Then
        oAccess.CloseCurrentDatabase
        Set oAccess = Nothing
    End If
End Function

Repoint an Access Link table using ADO-ADOX

2009-02-03T07:07:00.000-08:00

The following routine repoints a link table to a different database.

'Purpose     :  Updates the underlying source of a link table in an Access database
'Inputs      :  sLinkDatabasePath path to the database.
'               sLinkToNewDatabase The path to the database repoint the link to.
'               sLinkTableName name of the link table to repoint.
'Outputs     :  Returns True if succeeded in repointing the table
'Notes       :  Requires a reference to reference to both ADO (MS ActiveX Data Objects) and MSADOX.DLL
'               (MS ADO Ext. 2.5 DLL and Security).
'Revisions   :

Function AccessLinkTableUpdate(sLinkDatabasePath As String, sLinkToNewDatabase As String, sLinkTableName As String) As Boolean

Dim catDB As ADOX.Catalog
   
 On Error GoTo ErrFailed
 Set catDB = New ADOX.Catalog
    'Open a catalog on the database which contains the table to refresh.
.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sLinkDatabasePath
 catDB.Tables(sLinkTableName).Type = "LINK" Then
.Tables(sLinkTableName).Properties("Jet OLEDB:Link Datasource") = sLinkToNewDatabase
AccessLinkTableUpdate = True
    End If
    Set catDB = Nothing
    Exit Function

ErrFailed:
    On Error GoTo 0
    AccessLinkTableUpdate = False
End Function

Read data from a workbook using ADO

2009-02-03T07:03:00.000-08:00

The following code reads data from closed Excel workbooks using ADO with an ODBC driver.

Purpose     :  Extracts data from a closed workbook to an array
Inputs      :  sSourceFile                     The path and file name of the workbook to read data from.
               sRange                          The range reference (or named range) to read the data from.
               [sSheetName]                    The name of the sheet to return the data from. If not specified returns
                                               data from first sheet.
               [bReturnHeadings]               If True returns the Column Headings (i.e. the first row in the range).
                                               Note: This alters the shape of the output array to an array in an array.
Outputs     :  Returns a 2d variant array containing the values in the specified range.
Notes       :  Requires a reference to the Microsoft ActiveX Data Objects library
Could also use OLEDB JET 4.0 Driver 

"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sSourceFile & ";Extended Properties=""Excel 8.0;HDR=Yes"""


Function WorkbookReadRange(sSourceFile As String, sRange As String, Optional sSheetName As String, Optional bReturnHeadings As Boolean) As Variant
    Dim conWkb As ADODB.Connection, rsWkbCells As ADODB.Recordset, sConString As String
    Dim lThisField As Long, avResults As Variant, avHeadings As Variant
   
    On Error GoTo ErrFailed
    sConString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & sSourceFile
    Set conWkb = New ADODB.Connection
    'open connection
    conWkb.Open sConString
    If Len(sSheetName) Then
        'Get data from specified sheet
        Set rsWkbCells = conWkb.Execute("Select * from " & Chr(34) & sSheetName & "$" & sRange & Chr$(34))
    Else
        'Get data from first sheet
        Set rsWkbCells = conWkb.Execute("Select * from " & sRange)
    End If
    If rsWkbCells.EOF Then
        'Return a 1d array
        'Get headings
        ReDim avHeadings(0 To 0, 0 To rsWkbCells.Fields.Count - 1)
        For lThisField = 0 To rsWkbCells.Fields.Count - 1
            avHeadings(0, lThisField) = rsWkbCells.Fields(lThisField).Name
        Next
        WorkbookReadRange = avHeadings
    Else
        'Return a 2d array
        If bReturnHeadings Then
            'Get cells
            avResults = rsWkbCells.GetRows
            'Get headings
            ReDim avHeadings(0 To rsWkbCells.Fields.Count - 1, 0 To 0)
            For lThisField = 0 To rsWkbCells.Fields.Count - 1
                avHeadings(lThisField, 0) = rsWkbCells.Fields(lThisField).Name
            Next
            WorkbookReadRange = Array(avHeadings, avResults)
        Else
            'Get cells
            WorkbookReadRange = rsWkbCells.GetRows
        End If
    End If
    'Disconnect and destroy DB objects
    rsWkbCells.Close
    conWkb.Close
    Set rsWkbCells = Nothing
    Set conWkb = Nothing
    On Error GoTo 0
    Exit Function

ErrFailed:
   'Return error message
    WorkbookReadRange = Err.Description

    If conWkb.State <> adStateClosed Then
        conWkb.Close
    End If
  
    Set rsWkbCells = Nothing
    Set conWkb = Nothing
End Function

'Demonstration Routine
Sub Test()
    Dim avCellValues As Variant, vThisCell As Variant
    avCellValues = WorkbookReadRange("C:\book1.xls", "A1:B2", "Sheet1")
    If IsArray(avCellValues) Then
        For Each vThisCell In avCellValues
            Debug.Print vThisCell
        Next
    End If
End Sub

Return table names from Access-SQL Server

2009-02-03T06:59:00.000-08:00

The function below uses ADOX (Microsoft ADO Ext 2.5 for DLL and Security) to return all the table names for a given connection or connection string.

Purpose : Returns all the tables in an Access or SQL Server database
Inputs : A valid connection string or ADO Connection
Outputs : A collection of Table Names

CODE :

Public Function TableNames(Optional sConnectionString As String, Optional cCN As ADODB.Connection) As Collection
Dim oCatalog As New ADOX.Catalog, colTableNames As New Collection
Dim oTables As ADOX.Tables, oTable As ADOX.Table
Dim oConnection As New ADODB.Connection

On Error GoTo ExitSub
If Len(sConnectionString) Then
oConnection.ConnectionString = sConnectionString
oConnection.Open sConnectionString
Else
Set oConnection = cCN
End If
Set oCatalog.ActiveConnection = oConnection
Set oTables = oCatalog.Tables

For Each oTable In oTables
colTableNames.Add oTable.Name
Next
Set TableNames = colTableNames

ExitSub:
On Error Resume Next
If Len(sConnectionString) Then
'Close Temporary Connection
If oConnection.State <> 0 Then
oConnection.Close
End If
End If
Set oConnection = Nothing
Set oCatalog = Nothing
Set oTable = Nothing
Set oTables = Nothing
Exit Function
ErrFailed:
Debug.Print Err.Description
Debug.Assert False
Resume ExitSub
End Function

'Example
Private Sub Form_Load()
Dim colTableNames As Collection, vTable As Variant
Set colTableNames = TableNames("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Inetpub\GFX-IT\database\support.mdb; Persist Security Info=False")
For Each vTable In colTableNames
Debug.Print "Table Name: " & vTable
Next
End Sub

Retrieve a list of the users logged on to an Access-Jet Database

2009-02-03T06:54:00.000-08:00

Option Explicit

'----------Type to hold results------------
'For each person who opens a shared database, the Jet database engine writes an entry
'in the database's .ldb file. The size of each .ldb entry is 64 bytes. The first 32
'bytes contains the computer name. The second 32 bytes contains the
'security name (such as Admin).
Private Type tDBUser
    UserName As String * 32
    SecurityName As String * 32
End Type


'Purpose     :  Retreives a list of users attached to an Access Database by parsing the ldb file
'Inputs      :  asUsers                         See outputs
'               sLDBFilePath                    The path and file name of the ldb file
'Outputs     :  asUsers                         A 2d string array 1 to 2, 1 to Number of users
'                                               Where   asUsers(1,1)      =       First user name
'                                                       asUsers(2,1)      =       User's security access
'               Returns 0 if their are no users or the lock file doesn't exist.
'               Returns -1 on error.


Function DatabaseUsers(ByRef asUsers() As String, sLDBFilePath As String) As Long
    Const clMaxUsers As Long = 255      'The maximum number of concurrent users that the Jet database engine supports is 255
    Dim iFileNum As Integer
    Dim tThisUser As tDBUser
   
    On Error GoTo ErrFailed
    If Len(Dir$(sLDBFilePath)) > 0 And Len(sLDBFilePath) > 0 Then
        'Lock file exists, open file.
        iFileNum = FreeFile
        Open sLDBFilePath For Random As #iFileNum Len = Len(tThisUser)
        'Create buffer to store results
        ReDim asUsers(1 To 2, 1 To clMaxUsers)
        'Read data into fixed length type
        Get iFileNum, 1, tThisUser
        Do While Not EOF(iFileNum)
            DatabaseUsers = DatabaseUsers + 1
            asUsers(1, DatabaseUsers) = Left$(tThisUser.UserName, InStr(1, tThisUser.UserName, vbNullChar) - 1)
            asUsers(2, DatabaseUsers) = Left$(tThisUser.SecurityName, InStr(1, tThisUser.SecurityName, vbNullChar) - 1)
            'Read next record
            Get iFileNum, DatabaseUsers + 1, tThisUser
        Loop
        'Close file
        Close #iFileNum
        'Resize results
        ReDim Preserve asUsers(1 To 2, 1 To DatabaseUsers)
    Else
        'No users attached
        Erase asUsers
    End If
    Exit Function
ErrFailed:
    DatabaseUsers = -1
    Erase asUsers
End Function

'Demonstration routine
Sub Test()
    Dim asUsers() As String, lNumUsers As Long, lThisUser As Long

    lNumUsers = DatabaseUsers(asUsers, "D:\Work\Visual Basic\Net Send\NetSend.ldb")
    For lThisUser = 1 To lNumUsers
        Debug.Print "User Name: " & asUsers(1, lThisUser)
        Debug.Print "Security : " & asUsers(2, lThisUser)
    Next
End Sub

Returning an asynchronous client side recorset with ADO

2009-02-03T06:49:00.000-08:00

The following function below illustrates how you would run an ADO client side (disconnected) query asynchronously:

Private Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

'Purpose     :  Executes a disconnect ADO query asynchronously.
'Inputs      :  sSql                            The SQL to execute.
'               oCon                            The connection to execute against.
'               [lQueryTimeout]                 If specified is the amount of time to wait (in secs) before aborting the query
'Outputs     :  Returns a recordset contain the results of the query


Function RecordsetOpenAsync(sSql As String, oCon As ADODB.Connection, Optional lQueryTimeout As Long = -1) As ADODB.Recordset
    Dim oRs As ADODB.Recordset, lQueryTimeoutOld As Long
    On Error GoTo ErrFailed
   
    'Create recordset
    Set oRs = New Recordset
   
    If lQueryTimeout <> -1 Then
        'Store and set query timeout
        lQueryTimeoutOld = oCon.CommandTimeout
        oCon.CommandTimeout = lQueryTimeout
    End If
   
    'Set cursor to client
    oRs.CursorLocation = adUseClient
   
    'Open recorset
    'Using the "adAsyncExecute" option means the query returns immediately. If you
    'use the "adAsync" option the query will return after "Initial Fetch Size" rows have been
    'returned (see oRs.Properties("Initial Fetch Size") + oRs.Properties("Background Fetch Size"))
    oRs.Open sSql, oCon, adOpenStatic, adLockBatchOptimistic, adAsyncExecute
   
    'Wait for recordset to finish fetching
    Do While oRs.state <> adStateOpen
        Sleep 20
        DoEvents
    Loop
   
    'Disconnect recordset
    If oRs.EOF = False Then
        'Results are pending. Move the cursor across the results to fetch them (onto the client)
        oRs.MoveLast
        oRs.MoveFirst
    End If
    'Release reference to connection
    Set oRs.ActiveConnection = Nothing
   
    If lQueryTimeout <> -1 Then
        'Restore query timeout
        oCon.CommandTimeout = lQueryTimeoutOld
    End If
   
    'Return recordset
    Set RecordsetOpenAsync = oRs
   
    Exit Function
   
ErrFailed:
    'Error occured
    Debug.Print Err.Description
    Debug.Assert False
    Set RecordsetOpenAsync = Nothing
End Function

Updating a database using a disconnected recordset

2009-02-03T06:45:00.000-08:00

Option Explicit

'Purpose     :  Open a disconnected recordset.
'Inputs      :  oCon                        The connection to open the recordset on.
'               sSQL                        The SQL to open the recordset with.
'               oRS                         The resulting recordset.
'Outputs     :  Returns True if the recordset was opened and contained results.


Public Function RSOpenDisconnected(oCon As ADODB.Connection, sSQL As String, oRS As ADODB.Recordset, Optional eLocking As LockTypeEnum = adLockBatchOptimistic) As Boolean
    On Error GoTo ErrFailed
    If oCon.State = adStateOpen Then
        'Connection is open
        Set oRS = New ADODB.Recordset
        'Set cursor to client (i.e. Local Machine)
        oRS.CursorLocation = adUseClient
        'Open Recordset (NB. The CursorType is always "adOpenStatic" for client-side cursors)
        oRS.Open sSQL, oCon, adOpenStatic, eLocking
        'Set connection to nothing (disconnect recordset)
        Set oRS.ActiveConnection = Nothing
        If oRS.EOF = False Then
            'Return results
            RSOpenDisconnected = True
        Else
            'Empty recorset
            RSOpenDisconnected = False
        End If
    End If
    Exit Function

ErrFailed:
    Debug.Print "Failed to open recordset: " & Err.Description
    Debug.Assert False  'Error occurred
    RSOpenDisconnected = False
    On Error GoTo 0
End Function


'Demonstrates how to open a disconnected recordset and then update a value in
'a field in the database.
Sub Test()
    Dim oRS As ADODB.Recordset
    Dim oConn As ADODB.Connection
    Const clRecordUpdated As Long = -2147217864
   
    On Error GoTo ErrUpdateFailed
    'Open a connection to a database
    Set oConn = New ADODB.Connection
    oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyPath\MyDatabase.mdb; Persist Security Info=False"
    'Open a disconnected recordset
    RSOpenDisconnected oConn, "Select * from tblHoliday", oRS
    'Update a field in the recordset
    oRS.Fields("MyField").Value = "My New Value"
    'Reconnect to database
    Set oRS.ActiveConnection = oConn
   
    'Update table
    oRS.UpdateBatch
   
    'Close the connection
    oRS.Close
    Set oRS = Nothing
    oConn.Close
    Set oConn = Nothing
   
    Exit Sub
   
ErrUpdateFailed:
    If Err.Number = clRecordUpdated Then
        MsgBox "The record you altered has been altered by another user... " & vbNewLine & Err.Description, vbCritical
    Else
        MsgBox "Error in disconnected update routine... " & vbNewLine & Err.Description, vbCritical
    End If
End Sub

Adding a horizontal scroll bar to a listbox

2009-01-30T22:52:00.000-08:00

Option Explicit

Private Declare Function SendMessageA Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


'Purpose     :  Adds items to a listbox and if neccessary sets the
'               width of the horizontal scroll bar to the maximum width of the
'               items in the listbox.
'Inputs      :  lbListbox                   The listbox to add the item to.
'               sItemText                   The text to add to the listbox.
'               [iIndex]                    The position within the object where the new item or row is placed.
'Outputs     :  Returns True on success
'Notes       :
'Revisions   :
'Assumptions : 

Function ListboxAddItem(lbListbox As ListBox, sItemText As String, Optional iIndex As Integer = -1) as Boolean
    Dim fTextWidth As Single, fExistScrollWidth As Single
    Dim oParentFont As StdFont
    Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193

    On Error Resume Next

    'Add item to listbox
    If iIndex > -1 Then
        lbListbox.AddItem sItemText, iIndex
    Else
        lbListbox.AddItem sItemText
    End If

    'Store the form's original font
    Set oParentFont = lbListbox.Parent.Font
    'Set the form's font to the listbox's font
    Set lbListbox.Parent.Font = lbListbox.Font
    'Get width of text on the form
    fTextWidth = lbListbox.Parent.TextWidth(sItemText & " ")        'Extra space allows for vertical scroll bar
    'Restore the form's font
    Set lbListbox.Parent.Font = oParentFont
   
    'Get the width of the existing scroll bar
    fExistScrollWidth = SendMessageA(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)
   
    If lbListbox.Parent.ScaleMode = vbTwips Then
        'Change twips to pixels
        fTextWidth = fTextWidth / Screen.TwipsPerPixelX
    End If
   
    If fTextWidth > fExistScrollWidth Then
        'Increase width of scroll bar
        Call SendMessageA(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
    End If
    ListboxAddItem = (Err.Number = 0)
End Function


'Purpose     :  Modifies the text of an item in a listbox and if neccessary sets the
'               width of the horizontal scroll bar to the maximum width of the
'               items in the listbox.
'Inputs      :  lbListbox                   The listbox to update the item in.
'               sNewItemText                The new text for the item in the listbox.
'               [iIndex]                    The index of the item to update within the listbox.
'Outputs     :  Returns True on Success
'Notes       :
'Revisions   :
'Assumptions :

Function ListboxUpdateItem(lbListbox As ListBox, sNewItemText As String, iIndex As Integer) As Boolean
    Dim fTextWidth As Single, fExistScrollWidth As Single
    Dim oParentFont As StdFont
    Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193
   
    'Add item to listbox
    On Error GoTo ErrFailed
    If lbListbox.List(iIndex) <> sNewItemText Then
        lbListbox.List(iIndex) = sNewItemText
        'Get width of text
        Set oParentFont = lbListbox.Parent.Font
        Set lbListbox.Parent.Font = lbListbox.Font
        fTextWidth = lbListbox.Parent.TextWidth(sNewItemText & " ")        'Extra space allows for vertical scroll bar
        Set lbListbox.Parent.Font = oParentFont
        fExistScrollWidth = SendMessageA(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)
       
        If lbListbox.Parent.ScaleMode = vbTwips Then
            'Change twips to pixels
            fTextWidth = fTextWidth / Screen.TwipsPerPixelX
        End If
       
        If fTextWidth > fExistScrollWidth Then
            'Increase width of scroll bar
            Call SendMessageA(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
        End If
    End If
    ListboxUpdateItem = True

    Exit Function
   
ErrFailed:
    Debug.Print "Error in ListboxAddItem: " & lbListbox.Name & " Description: " & Err.Description
    ListboxUpdateItem = False
End Function


'Purpose     :  Adds a horizontal scroll bar to a listbox
'Inputs      :  lbListbox                   The listbox to add the scrollbar to.
'Outputs     :  Returns True on success
'Notes       :
'Revisions   :
'Assumptions :

Function ListboxAddHorizontalScollBar(lbListbox As ListBox) As Boolean
    On Error GoTo ErrFailed
    Dim fTextWidth As Single
    Dim oParentFont As StdFont, fExistScrollWidth As Single
    Dim lThisListItem As Long, fMaxScollWidth As Single, lMaxTextLen As Long
    Const LB_SETHORIZONTALEXTENT = &H194, LB_GETHORIZONTALEXTENT = &H193

    'Add item to listbox
    On Error GoTo ErrFailed
    'Set the parent font
    Set oParentFont = lbListbox.Parent.font
    Set lbListbox.Parent.font = lbListbox.font
    Set lbListbox.Parent.font = oParentFont

    'Determine max. length of text
    For lThisListItem = 0 To lbListbox.ListCount - 1
        If Len(lbListbox.list(lThisListItem)) > lMaxTextLen Then
            lMaxTextLen = Len(lbListbox.list(lThisListItem))
        End If
    Next

    'Get the text length
    fTextWidth = lbListbox.Parent.TextWidth(String(lMaxTextLen + 1, "W"))       'Extra space allows for vertical scroll bar
    'Restore the form's font
    Set lbListbox.Parent.font = oParentFont

    'Get the width of the existing scroll bar
    fExistScrollWidth = SendMessage(lbListbox.hwnd, LB_GETHORIZONTALEXTENT, 0, 0)

    If lbListbox.Parent.ScaleMode = vbTwips Then
        'Change twips to pixels
        fTextWidth = fTextWidth / Screen.TwipsPerPixelX
    End If

    If fTextWidth > fExistScrollWidth Then
        'Increase width of scroll bar
        Call SendMessage(lbListbox.hwnd, LB_SETHORIZONTALEXTENT, fTextWidth, 0)
    End If
    ListboxAddHorizontalScollBar = (err.number = 0)
   
    Exit Function

ErrFailed:
    Debug.Print err.description
    Debug.Assert False
    ListboxAddHorizontalScollBar = (err.number = 0)
End Function

Calling ODBC from ADO to connect to thirdparty driver

2009-01-30T22:49:00.000-08:00

Dim ADOCN As New ADODB.Connection
Dim ADORS As New ADODB.Recordset
Dim mysql  As String
With ADOCN
'here how to call odbc from ADO!
   .ConnectionString = "DSN=odbc namet;UID=YOURUSERID;PWD=YOURPASSWORD;"
.Mode = adModeReadOnly
   .Open
End With

With ADORS
   .CursorLocation = adUseClient
   .CursorType = adOpenKeyset
   .LockType = adLockOptimistic
   .ActiveConnection = ADOCN
    mysql = "select whatever from my table"
   .Source = mysql
   .Open
'for good preformance, I did store the record set in variant type variable so I can disconnect from host sooner

.ctiveConnection = Nothing
    myrows = .RecordCount
    mycola = .Fields.Count
    mydata = .GetRows()

'now I can loop through my result

Sending Crystal Reports to MAPI

2009-01-30T22:41:00.000-08:00

Dim App as New craxdrt.Application
Dim rpt as craxdrt.Report

Set rpt = App.OpenReport("\\cms_live\Reports\Report Maker
2k1\Admin\ImpBuddyProfile.RPT")

With rpt.ExportOptions
.DestinationType = crEDTEMailMAPI
.FormatType = crEFTPortableDocFormat

.MailToList = "steve"

.MailSubject = "Mail Subject"
.MailMessage = strMessage
End With

With rpt
.DisplayProgressDialog = False
.EnableParameterPrompting = False
.ParameterFields(1).AddCurrentValue "Any Old Value"
.Export False
End With

Finding the position of the first character from a list of characters

2009-01-24T07:30:00.000-08:00

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

    Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

    Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

'Purpose     :  Finds the position of the first character found in a string from a list of characters.
'Inputs      :  sSearchIn           The string to search for the first instance of a character from the character list
'               avChars             The list of characters to search through "sSearchIn" for
'Outputs     :  Returns the position of first instance of a character found in a string from the list of supplied characters,
'               or zero if none of the characters are found
'Example     :  If your wanted to find a line feed, you might use:
'               Debug.Print StringFindFirstChar("ABCDEF","B","E","F")
'               'This would return 2, i.e. the position of character "B"
'Revisions   :

Function StringFindFirstChar(sSearchIn As String, ParamArray avChars() As Variant) As Long
    Dim lPosChar As Long, lPosTest As Long, vChar As Variant
   
    On Error GoTo ErrFailed
    If Len(sSearchIn) Then
        For Each vChar In avChars
            lPosTest = InStr(1, sSearchIn, CStr(vChar))
            If lPosTest Then
                If lPosChar = 0 Then
                    lPosChar = lPosTest
                ElseIf lPosTest < lPosChar Then
                    lPosChar = lPosTest
                End If
            End If
        Next
    End If
    StringFindFirstChar = lPosChar
    Exit Function

ErrFailed:
    Debug.Print Err.Description
    Debug.Assert False
    'Try the next line
    Resume Next
End Function

Search for a specific string and replace it with another

2009-01-24T07:28:00.000-08:00

Function sReplace(SearchLine as String, SearchFor as String, ReplaceWith as String)
    Dim vSearchLine as String, found as Integer
   
    found = InStr(SearchLine, SearchFor): vSearchLine = SearchLine
    If found <> 0 Then
        vSearchLine = ""
        If found > 1 Then vSearchLine = Left(SearchLine, found - 1)
        vSearchLine = vSearchLine + ReplaceWith
        If found + Len(SearchFor) - 1 < Len(SearchLine) Then _
            vSearchLine = vSearchLine + Right$(SearchLine, Len(SearchLine) - found - Len(SearchFor) + 1)
    end If
    sReplace = vSearchLine
   
End Function

* another routine *


Only 17 lines of code for a super-fast find-and-replace function:

-- start code --

    '  Copy *both* functions to VBScript or VB application:
    '  FindReplace and ReplaceFirstInstance
    '
    Function FindReplace(SourceString, SearchString, ReplaceString)
        tmpString1 = SourceString
        do Until vFixed
            tmpString2 = tmpString1
            tmpString1 = ReplaceFirstInstance(tmpString1, SearchString,ReplaceString)
            If tmpString1 = tmpString2 Then vFixed = True
        Loop
        FindReplace = tmpString1
    end Function

    Function ReplaceFirstInstance(SourceString, SearchString, ReplaceString)
        FoundLoc = InStr(1, SourceString, SearchString)
        If FoundLoc <> 0 Then
            ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
        ReplaceString & Right(SourceString, _
        Len(SourceString) - (FoundLoc - 1) - Len(SearchString))
        Else
            ReplaceFirstInstance = SourceString
        end If
    end Function

--- end code -

 Just to clarify, one function is used to go through the entire string and
replace all instances of the search string ("Replace All").  The other
function is used to only replace the first instance of the search string
("Replace").  The former loops the latter until there are no more instances
of the search string.
>


Function FindReplace(SourceString, searchstring, replacestring)
    tmpString1 = SourceString
    do Until vFixed
        tmpString2 = tmpString1
        tmpString1 = ReplaceFirstInstance(tmpString1, searchstring,
replacestring)
        If tmpString1 = tmpString2 Then vFixed = True
    loop
    FindReplace = tmpString1
End Function

Function ReplaceFirstInstance(SourceString, searchstring, replacestring)
    Static StartLoc '*
    If StartLoc = 0 Then StartLoc = 1 '*
    FoundLoc = InStr(StartLoc, SourceString, searchstring) '*
    If FoundLoc <> 0 Then
            ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
            replacestring & Right(SourceString, _
            Len(SourceString) - (FoundLoc - 1) - Len(searchstring))
            StartLoc = FoundLoc + Len(replacestring) '*
    Else
        StartLoc = 1 '*
        ReplaceFirstInstance = SourceString
    end If
End Function


Return

Search and Replace Text

2009-01-24T07:26:00.000-08:00

To search and replace text in a variable use the following (please read the notes for guidance on how to use this routine).

'Purpose : Searches and replaces all instances of a string within a variable.
'Inputs : sText The string to search.
' sReplaceThis The string to replace.
' sWithThis The replacement string.
' [lNumReplacements] Returns the number of times a replacement was made.
'Outputs : N/A
'Notes : This routines output parameters are passed in ByRef for speed and hence it should be called:
' Dim sOutputText as String 'Create a variable to hold the value in
' sOutputText = "aaaaaa"
' SearchAndReplace sOutputText, "a", "b"
' Debug.Print sOutputText

Sub SearchAndReplace(ByRef sText As String, ByVal sReplaceThis As String, ByVal sWithThis As String, Optional ByRef lNumReplacements As Long)
Dim lPos As Long, lLenOriginal As Long, lLenReplace As Long

lLenOriginal = Len(sReplaceThis)
lLenReplace = Len(sWithThis)

If lLenOriginal Then
lPos = InStr(1, sText, sReplaceThis)
Do While lPos > 0
lNumReplacements = lNumReplacements + 1
If lLenOriginal = lLenReplace Then
Mid$(sText, lPos, Len(sReplaceThis)) = sWithThis
Else
sText = Left$(sText, lPos - 1) & sWithThis & Mid$(sText, lPos + lLenOriginal)
End If
lPos = InStr(lPos + lLenOriginal, sText, sReplaceThis)
Loop
End If
End Sub

Finding the position of the first character from a list of characters

2009-01-24T07:24:00.000-08:00

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

The code below is useful when you want to find the position of first character from a list of characters within a string. This would typically be used when looking for carriage returns, eg:

Debug.Print StringFirstFirstChars(sSearch,vbNewline,vbCr,vbLf)

'Purpose : Finds the position of the first character found in a string from a list of characters.
'Inputs : sSearchIn The string to search for the first instance of a character from the character list
' avChars The list of characters to search through "sSearchIn" for
'Outputs : Returns the position of first instance of a character found in a string from the list of supplied characters,
' or zero if none of the characters are found
'Example : If your wanted to find a line feed, you might use:
' Debug.Print StringFindFirstChar("ABCDEF","B","E","F")
' 'This would return 2, i.e. the position of character "B"
'Revisions :

Function StringFindFirstChar(sSearchIn As String, ParamArray avChars() As Variant) As Long
Dim lPosChar As Long, lPosTest As Long, vChar As Variant

On Error GoTo ErrFailed
If Len(sSearchIn) Then
For Each vChar In avChars
lPosTest = InStr(1, sSearchIn, CStr(vChar))
If lPosTest Then
If lPosChar = 0 Then
lPosChar = lPosTest
ElseIf lPosTest <>
lPosChar = lPosTest
End If
End If
Next
End If
StringFindFirstChar = lPosChar
Exit Function

ErrFailed:
Debug.Print Err.Description
Debug.Assert False
'Try the next line
Resume Next
End Function

Trin Function : Performing a custom Trim() on an input string

2009-01-24T07:11:00.000-08:00

The RTrim, LTrim and Trim functions are useful from removing blank spaces. However, sometimes you want to remove different trailing/leading characters (eg, Remove all the vbNewLine from the start and end of a string). The function below allows you to specify a custom Trim:

'Purpose : Trims trailing a leading characters from a string buffer
'Inputs : sValue The string to trim
' sRemove The character/s to remove from the start/end of the sValue
' [bRtrim] If True removes any matching right hand side chars
' [bLtrim] If True removes any matching left hand side chars
' [eCompare] The method of comparison
'Outputs : Returns the string trimed from the specified characters
'Notes : Trim2("aaaaaBBBBCCCaaaa", "a") returns "BBBBCCC"

Function Trim2(ByVal sValue As String, sRemove As String, Optional bRtrim As Boolean = True, Optional bLTrim As Boolean = True, Optional eCompare As VbCompareMethod = vbBinaryCompare) As String
Dim lPos As Long, lLastChar As Long, lLenRemove As Long
On Error GoTo ErrFailed

lLenRemove = Len(sRemove)

If lLenRemove > 0 And Len(sValue) > 0 Then
If bLTrim Then
'Remove the left hand chars
lPos = 1 - lLenRemove
lLastChar = 1 - lLenRemove

'Loop finding the chars to replace
Do
lPos = InStr(lPos + lLenRemove, sValue, sRemove, eCompare)
If lPos = lLastChar + lLenRemove Then
lLastChar = lPos
Else
'Found all the matching characters
Exit Do
End If
Loop
If lLastChar Then
sValue = Mid$(sValue, lLastChar + lLenRemove)
End If
End If

If bRtrim = True And Len(sValue) > 0 Then
'Remove the right hand chars
lPos = Len(sValue) + 1
lLastChar = lPos

'Loop finding the chars to replace
Do
lPos = InStrRev(sValue, sRemove, lPos - 1, eCompare)
If lPos = lLastChar - lLenRemove Then
lLastChar = lPos
Else
'Found all the matching characters
Exit Do
End If
Loop
If lLastChar Then
sValue = Left$(sValue, lLastChar - 1)
End If
End If
End If
Trim2 = sValue
Exit Function

ErrFailed:
Debug.Print "Error in Trim2: " & Err.Description
Debug.Assert False
End Function