Folder Browsing Control

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: A user control resembling a combobox. When the dropdown button is clicked, a browse through a folder treeview to select a directory is displayed. Uses the SHBrowseForFolder function, amongst other APIs. A call back procedure is implemented showing the currently selected folder in the browse for folder dialog. User has the choice to select any system folder (Desktop, My Computer etc) as the root, or a custom folder. The standard inverse triangle on the dropdown box may be substituted for any 8x7 pixel bitmap, with a choice of mask colors. Full set of events, click() upon dialog close, Change() and DropDown() prior to opening of the dialog. Source also implements BitBlt() API function to copy transparent images.

Full source & test program included. Note: You must register the .ocx in the release folder using regsvr32 before using the test project.

Instructions: Click the link below to download the code. Select 'Save' from the IE popup dialog. Once downloaded, open the .zip file from your local drive using WinZip or a comparable program to view the contents.

DOWNLOAD NOW!!!!

Return image type and size from JPEG, GIF, BMP, & PNG files

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: This class module will return height, width, color depth, and image type from the following image formats: JPEG, GIF, BMP, & PNG.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Option Explicit

' Only the first X bytes of the file are read into a byte array.
' BUFFERSIZE is X. A larger number will use more memory and
' be slower. A smaller number may not be able to decode all
' JPEG files. Feel free to play with this number.
Private Const BUFFERSIZE As Long = 65535

' image type enum
Public Enum eImageType
itUNKNOWN = 0
itGIF = 1
itJPEG = 2
itPNG = 3
itBMP = 4
End Enum

' private member variables
Private m_Width As Long
Private m_Height As Long
Private m_Depth As Byte
Private m_ImageType As eImageType

'
' CImageInfo
'
' Author: David Crowell
' davidc@qtm.net
' http://www.qtm.net/~davidc
'
' Released to the public domain
' use however you wish
'
' CImageInfo will get the image type ,dimensions, and
' color depth from JPG, PNG, BMP, and GIF files.
'
' version date: June 16, 1999
'
' http://www.wotsit.org is a good source of
' file format information. This code would not have been
' possible without the files I found there.
'

' read-only properties

Public Property Get Width() As Long
Width = m_Width
End Property

Public Property Get Height() As Long
Height = m_Height
End Property

Public Property Get Depth() As Byte
Depth = m_Depth
End Property

Public Property Get ImageType() As eImageType
ImageType = m_ImageType
End Property

Public Sub ReadImageInfo(sFileName As String)
' This is the sub to call to retrieve information on a file.

' Byte array buffer to store part of the file
Dim bBuf(BUFFERSIZE) As Byte
' Open file number
Dim iFN As Integer

' Set all properties to default values
m_Width = 0
m_Height = 0
m_Depth = 0
m_ImageType = itUNKNOWN

' here we will load the first part of a file into a byte
'array the amount of the file stored here depends on
'the BUFFERSIZE constant
iFN = FreeFile
Open sFileName For Binary As iFN
Get #iFN, 1, bBuf()
Close iFN

If bBuf(0) = 137 And bBuf(1) = 80 And bBuf(2) = 78 Then
' this is a PNG file

m_ImageType = itPNG

' get bit depth
Select Case bBuf(25)
Case 0
' greyscale
m_Depth = bBuf(24)

Case 2
' RGB encoded
m_Depth = bBuf(24) * 3

Case 3
' Palette based, 8 bpp
m_Depth = 8

Case 4
' greyscale with alpha
m_Depth = bBuf(24) * 2

Case 6
' RGB encoded with alpha
m_Depth = bBuf(24) * 4

Case Else
' This value is outside of it's normal range, so
'we'll assume
' that this is not a valid file
m_ImageType = itUNKNOWN

End Select

If m_ImageType Then
' if the image is valid then

' get the width
m_Width = Mult(bBuf(19), bBuf(18))

' get the height
m_Height = Mult(bBuf(23), bBuf(22))
End If

End If

If bBuf(0) = 71 And bBuf(1) = 73 And bBuf(2) = 70 Then
' this is a GIF file

m_ImageType = itGIF

' get the width
m_Width = Mult(bBuf(6), bBuf(7))

' get the height
m_Height = Mult(bBuf(8), bBuf(9))

' get bit depth
m_Depth = (bBuf(10) And 7) + 1
End If

If bBuf(0) = 66 And bBuf(1) = 77 Then
' this is a BMP file

m_ImageType = itBMP

' get the width
m_Width = Mult(bBuf(18), bBuf(19))

' get the height
m_Height = Mult(bBuf(22), bBuf(23))

' get bit depth
m_Depth = bBuf(28)
End If

If m_ImageType = itUNKNOWN Then
' if the file is not one of the above type then
' check to see if it is a JPEG file
Dim lPos As Long

Do
' loop through looking for the byte sequence FF,D8,FF
' which marks the begining of a JPEG file
' lPos will be left at the postion of the start
If (bBuf(lPos) = &HFF And bBuf(lPos + 1) = &HD8 _
And bBuf(lPos + 2) = &HFF) _
Or (lPos >= BUFFERSIZE - 10) Then Exit Do

' move our pointer up
lPos = lPos + 1

' and continue
Loop

lPos = lPos + 2
If lPos >= BUFFERSIZE - 10 Then Exit Sub


Do
' loop through the markers until we find the one
'starting with FF,C0 which is the block containing the
'image information

Do
' loop until we find the beginning of the next marker
If bBuf(lPos) = &HFF And bBuf(lPos + 1) _
<> &HFF Then Exit Do
lPos = lPos + 1
If lPos >= BUFFERSIZE - 10 Then Exit Sub
Loop

' move pointer up
lPos = lPos + 1

Select Case bBuf(lPos)
Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, _
&HCD To &HCF
' we found the right block
Exit Do
End Select

' otherwise keep looking
lPos = lPos + Mult(bBuf(lPos + 2), bBuf(lPos + 1))

' check for end of buffer
If lPos >= BUFFERSIZE - 10 Then Exit Sub

Loop

' If we've gotten this far it is a JPEG and we are ready
' to grab the information.

m_ImageType = itJPEG

' get the height
m_Height = Mult(bBuf(lPos + 5), bBuf(lPos + 4))

' get the width
m_Width = Mult(bBuf(lPos + 7), bBuf(lPos + 6))

' get the color depth
m_Depth = bBuf(lPos + 8) * 8

End If

End Sub
Private Function Mult(lsb As Byte, msb As Byte) As Long
Mult = lsb + (msb * CLng(256))
End Function

Change a File's Last Modified Date Stamp

Version Compatibility: Visual Basic 5, Visual Basic 6

Instructions: Copy the declarations and code below and paste directly into your VB project.

Option Explicit

Private Type FILETIME
dwLowDate As Long
dwHighDate As Long
End Type

Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMillisecs As Integer
End Type

Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_WRITE = &H40000000

Private Declare Function CreateFile Lib "kernel32" Alias _
"CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) _
As Long

Private Declare Function LocalFileTimeToFileTime Lib _
"kernel32" (lpLocalFileTime As FILETIME, _
lpFileTime As FILETIME) As Long

Private Declare Function SetFileTime Lib "kernel32" _
(ByVal hFile As Long, ByVal MullP As Long, _
ByVal NullP2 As Long, lpLastWriteTime _
As FILETIME) As Long

Private Declare Function SystemTimeToFileTime Lib _
"kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime _
As FILETIME) As Long

Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long

Public Function SetFileDateTime(ByVal FileName As String, _
ByVal TheDate As String) As Boolean
'************************************************
'PURPOSE: Set File Date (and optionally time)
' for a given file)

'PARAMETERS: TheDate -- Date to Set File's Modified Date/Time
' FileName -- The File Name

'Returns: True if successful, false otherwise
'************************************************
If Dir(FileName) = "" Then Exit Function
If Not IsDate(TheDate) Then Exit Function

Dim lFileHnd As Long
Dim lRet As Long

Dim typFileTime As FILETIME
Dim typLocalTime As FILETIME
Dim typSystemTime As SYSTEMTIME

With typSystemTime
.wYear = Year(TheDate)
.wMonth = Month(TheDate)
.wDay = Day(TheDate)
.wDayOfWeek = Weekday(TheDate) - 1
.wHour = Hour(TheDate)
.wMinute = Minute(TheDate)
.wSecond = Second(TheDate)
End With

lRet = SystemTimeToFileTime(typSystemTime, typLocalTime)
lRet = LocalFileTimeToFileTime(typLocalTime, typFileTime)

lFileHnd = CreateFile(FileName, GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, _
OPEN_EXISTING, 0, 0)

lRet = SetFileTime(lFileHnd, ByVal 0&, ByVal 0&, _
typFileTime)

CloseHandle lFileHnd
SetFileDateTime = lRet > 0

End Function


A Better App.Path

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: App.Path returns a string with the "\" character at the end if the path is the root drive (e.g., "C:\") but without that character if it isn't (e.g., "C:\Program Files"). Most of the time we need the "\" at the end, so this function saves you the inconvenience of adding it every time.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Public Function AppPath() As String

Dim sAns As String
sAns = App.Path
If Right(App.Path, 1) <> "\" Then sAns = sAns & "\"
AppPath = sAns

End Function

Bandwidth Monitor

Version Compatibility: Visual Basic 6

More information: A program for monitoring bandwidth usage as well as a demo of UI techniques, such as a form that will blend into your desktop so it looks like it is part of it. The stats form that will "Roll" out of the main form. It will remember where you have your forms at startup, has many options and is very custmizable.

Instructions: Click the link below to download the code. Select 'Save' from the IE popup dialog. Once downloaded, open the .zip file from your local drive using WinZip or a comparable program to view the contents.

DOWNOAD NOW!!!!

Read All Lines from a Text File into a String Array

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: A reference to the Microsoft Scripting Runtime is required. Refer to code's comments for usage and other details.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Public Sub FileToArray(ByVal FileName As String, _
ByRef TheArray As Variant)
'PURPOSE: Puts all lines of file into a string array
'PARAMETERS: FileName = FullPath of File
' TheArray = StringArray to which contents
' Of File will be added.
'Example
' Dim sArray() as String
' FileToArray "C:\MyTextFile.txt", sArray
' For lCtr = 0 to Ubound(sArray)
' Debug.Print sArray(lCtr)
' Next

'NOTES:
' -- Requires a reference to Microsoft Scripting Runtime
' Library
' -- You can write this method in a number of different ways
' For instance, you can take advantage of VB 6's ability to
' return an array.
' -- You can also read all the contents of the file and use the
' Split function with vbCrlf as the delimiter, but I
' wanted to illustrate use of the ReadLine
' and AtEndOfStream methods.
'**********************************************************

Dim oFSO As New FileSystemObject
Dim oFSTR As Scripting.TextStream
Dim ret As Long
Dim lCtr As Long

If Dir(FileName) = "" Then Exit Sub

'Check if string array was passed
'If you want to permit other type of arrays (e.g.,
'variant) remove or modify this line
If VarType(TheArray) <> vbArray + vbString Then Exit Sub

On Error GoTo ErrorHandler
Set oFSTR = oFSO.OpenTextFile(FileName)

Do While Not oFSTR.AtEndOfStream
ReDim Preserve TheArray(lCtr) As String
TheArray(lCtr) = oFSTR.ReadLine
lCtr = lCtr + 1
DoEvents 'optional but with large file
'program will appear to hang
'without it
Loop
oFSTR.Close

ErrorHandler:
Set oFSTR = Nothing
End Sub

InputBox with Password Characters

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: This code shows a simple way of 'hooking' modal windows (MsgBox or InputBox) and changing their behavior.

Instructions: Copy the declarations and code below and paste directly into your VB project.

'PUT BELOW DECLARATIONS IN A .BAS MODULE

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias _
"FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Public Declare Function SetTimer& Lib "user32" _
(ByVal hwnd&, ByVal nIDEvent&, ByVal uElapse&, ByVal _
lpTimerFunc&)

Private Declare Function KillTimer& Lib "user32" _
(ByVal hwnd&, ByVal nIDEvent&)

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

Const EM_SETPASSWORDCHAR = &HCC
Public Const NV_INPUTBOX As Long = &H5000&

Display Tables, Fields, and Data in MSFlexGrid

Version Compatibility: Visual Basic 6

More information: This program displays list of tables available in a selected access (mdb) file. It displays a list of tables in a list box. Whenever you click on any table, it then displays its structure in another listbox. And in an MSFlexgrid, a list of records in that table is displayed. This example is done using DAO.

Instructions: Click the link below to download the code. Select 'Save' from the IE popup dialog. Once downloaded, open the .zip file from your local drive using WinZip or a comparable program to view the contents.

DOWNOAD NOW!!!!

ADO.NET Demonstration for VB.NET

Version Compatibility: Visual Basic.NET

More information: This is a simple example illustrating some of the new objects in ADO.NET, the new version of ADO will ship with Visual Basic.NET. The example illustrates use of the DataSet Object, which is like a disconnected recordset in ADO. In ADO.NET, connectionless database applications are emphasized, and the DataSet object is a major part of how they are implemented.

Originally developed for VB.NET beta 2; verified to work on VB.NET version 1.0, 03/07/02.

Instructions: Click the link below to download the code. Select 'Save' from the IE popup dialog. Once downloaded, open the .zip file from your local drive using WinZip or a comparable program to view the contents.

Download Now!!!

Change a Password for an Access Database

Version Compatibility: Visual Basic 5, Visual Basic 6

Instructions: Copy the declarations and code below and paste directly into your VB project

Public Function ChangeDatabasePassword(DBPath As String, _
newPassword As String, oldPassWord As String) As Boolean

'Usage: Change DatabasePassword
'Parameters: sDBPath: Full Path to Access Database
'newPassword: the password
'oldPassword: the previous password
'returns true on success false otherwise

If Dir(DBPath) = "" Then Exit Function

Dim db As DAO.Database

On Error Resume Next
Set db = OpenDatabase(DBPath, True, False, ";pwd=" & oldPassWord)
If Err.Number <> 0 Then Exit Function
db.newPassword oldPassWord, newPassword
ChangeDatabasePassword = Err.Number = 0
db.Close

End Function

Change Collation Settings for an Entire SQL Server 2000 Data

Version Compatibility: Visual Basic.NET, ASP.NET

More information: If you use SQL Server 2000, you may have come across a situation where you import data from another sql, then find queries that reference new and old data together fail because the default collation settings for two servers were different. To address this, you normally have to either change the collation settings for each character field one by one or rebuild the database in question. This VB.NET code offers another way, relying on system tables and views that are not that well documented. To use it, call the function MAIN_ROUTINE as demonstrated by the example. It should work in VB.NET or ASP.NET.

Please refer to the notes for a few issues. In particular, note that you will need sysadmin privileges on the SQL Server in order to do this, and that the change won't work on every single column, so you may want to log the columns where it doesn't work (not done here) in order to change those columns manually later.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Imports System.Data
Imports System.Data.OleDb

Private Sub MAIN_ROUTINE(ByVal Collation_Name As String)
'DEMO CALL:
' MAIN_ROUTINE("SQL_Latin1_General_CP1_CI_AS")

Dim connString As String
Dim arrTables As ArrayList
Dim sTable, sColumn As String
Dim iCtr, iCount As Integer

'NOTE: CHANGE CONNECTION STRING INFO TO MATCH YOURS. MUST HAVE
'SYS ADMIN PRIVILEGES
Dim cn As New OleDbConnection _
("Provider=SQLOLEDB.1;data source=sqlservername;user id=sa;password=mypassword;Initial Catalog=DBNAME;Connection Timeout=120")

Try

cn.Open()
Catch ex As Exception

Debug.WriteLine(ex.Message)
Exit Sub

End Try
GetDatabaseTables(cn)
arrTables = GetDatabaseTables(cn)
iCount = arrTables.Count - 1
For iCtr = 0 To iCount
ChangeCollation(cn, arrTables(iCtr), Collation_Name)
Next
cn.Close()
End Sub
Function GetDatabaseTables(ByVal cn As OleDbConnection) As ArrayList

'RETURNS: ARRAYLIST OF ALL TABLES IN A DATABASE
Dim objDataTable As DataTable = cn.GetOleDbSchemaTable(OleDbSchemaGuid.Tables, _
New Object() {Nothing, Nothing, Nothing, "TABLE"})


Dim arrListTables As New ArrayList()
Dim i As Integer
For i = 0 To objDataTable.Rows.Count - 1
arrListTables.Add(objDataTable.Rows(i)(2))

Next
Return arrListTables
End Function


Function ChangeCollation(ByVal cn As OleDbConnection, ByVal strTable As String, _
ByVal Collation_Name As String) As ArrayList


Dim arrListColumns As New ArrayList()

Dim objDt As DataTable
Dim objDr As DataRow
Dim objDS As New DataSet()
Dim objDA As OleDbDataAdapter

Dim objCommand As New OleDbCommand()

Dim sDataType As String
Dim sSQL As String
Dim sLen As String
Dim sColumn As String
Dim sNull As String

objDA = New OleDbDataAdapter _
("SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE TABLE_NAME = '" & strTable & "'", cn)
objDS.Tables.Add(strTable)
objDA.Fill(objDS, strTable)

Dim i As Integer



For i = 0 To objDS.Tables(strTable).Rows.Count - 1


If Not (objDS.Tables(strTable).Rows(i).Item("COLLATION_NAME") Is DBNull.Value) Then
sColumn = objDS.Tables(strTable).Rows(i).Item("COLUMN_NAME")

sDataType = objDS.Tables(strTable).Rows(i).Item("DATA_TYPE").ToString
sLen = objDS.Tables(strTable).Rows(i).Item("CHARACTER_MAXIMUM_LENGTH").ToString
sNull = objDS.Tables(strTable).Rows(i).Item("IS_NULLABLE")
sNull = IIf(sNull = "YES", " NULL", " NOT NULL")

sSQL = "ALTER TABLE " & strTable & " ALTER COLUMN " & sColumn
sSQL &= " " & sDataType
If CInt(sLen) <= 8000 Then sSQL &= "(" & sLen & ")"
sSQL &= " COLLATE " & Collation_Name
sSQL &= sNull
Debug.WriteLine(sSQL)

objCommand = New OleDbCommand(sSQL, cn)
'THIS WILL FAIL SOMETIMES, DOESN'T WORK FOR TEXT FIELDS
'AND IF THERE IS A CONSTRAINT IN SOME CASES
'YOU MAY WANT TO LOG TO A TEXT FILE ON FAILURE SO YOU KNOW
'WHAT YOU NEED TO CHANGE MANUALLY
Try
objCommand.ExecuteNonQuery()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try

End If
Next

End Function

Strip HTML tags from a Web Page and save the Output to aTexT

Strip HTML tags from a Web Page and save the Output to a Text File

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: This .bas module includes a function that takes a string containing HTML as a parameter, and it returns the string with the HTML tags removed. The best thing about the function is how it formats the output, based on the tags. For instance, there is support for ordered lists, bulleted lists, and special characters. In addition, tables are recognized and outputted intelligently.

Using an optional parameter, you can save the text output to a file. Usage of the function is explained in detail within the code's comments.

This is a great module for browser based applications that want to add a Save as Text option, or web crawlers that need to strip HTML tags from pages before saving or indexing them.

Instructions: Click the link below to download the code. Select 'Save' from the IE popup dialog. Once downloaded, open the .zip file from your local drive using WinZip or a comparable program to view the contents.


DOWNLOAD NOW!!!

Create and email a word document from ASP

Version Compatibility: ASP

More information: This example ASP subroutine will create a word document "on the fly" and email it, before deleting it from the server.

To email, the subroutine uses ASPMail (Free) from Flicks Software (www.flicks.com). You may replace it with any mail component you wish.

NOTE: You will have to change a number of hard coded values in the snippet below based on your needs. See the code's comments for places that require a change.

Instructions: Copy the declarations and code below and paste directly into your VB project

Sub CreateAppraisalForm(Manager,Email,Appraisee)

' CREATE WORD DOCUMENT

Set WordApp = CreateObject("word.application")
Set WordDoc = WordApp.Documents.Add()

WordApp.Application.Visible = False

Set MyRange1 = WordDoc.Paragraphs.Add.Range
MyRange1.InsertBefore("Appraisal Form")
MyRange1.Style = "Heading 1"

Set MyRange1 = WordDoc.Paragraphs.Add.Range
MyRange1.InsertBefore("Manager: " & Manager & vbcrlf & "Appraisee: " & Appraisee)
MyRange1.Font.Bold = true

Set MyRange1 = WordDoc.Paragraphs.Add.Range
MyRange1.InsertBefore(vbcrlf & "Please fill in all the required sections and return to HR via the internal mail system.")

' Set the directory location to store the generated documents
WordDocPath = Server.MapPath("\alastair\appraisals\forms")
' Use the unique session ID as the filename.
WordDoc.SaveAs WordDocPath & "\" & session.sessionID & ".doc"
WordDoc.Close
WordApp.Quit

Set WordDoc = Nothing
Set WordApp = Nothing

' EMAIL WORD DOCUMENT

Set mailer = Server.CreateObject("ASPMAIL.ASPMailCtrl.1")
recipient = Email
sender = "vance@ukonline.co.uk"
subject = "Requested Form"
message = "Please find the requested document attached."
attach = WordDocPath & "\" & session.SessionID & ".doc"
'INSERT YOUR MAIL SERVER HERE
mailserver = "xxx.xx.xx.xx"

result = mailer.SMAttach(mailserver, recipient, sender, subject, message, attach)

If result = "" Then

' DELETE WORD DOCUMENT FROM SERVER
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(WordDocPath & "\" & session.SessionID & ".doc")

Response.Write "The requested form will arrive in your inbox (email) within a few minutes. Please complete and return to HR asap."

Else
Response.Write "There has been an error sending the document to you." & vbcrlf
Response.Write "Right click the following link and select ""Save Target As..."" to retrieve the word document." & vbcrlf & vbcrlf
Response.Write "Generated Document" & vbcrlf & vbcrlf


End if

End Sub

Database Coder Add-In Version 1.31:

Database Coder Add-In Version 1.31: Generates Code to Create Replicas of Access Databases

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: Zip file contains two projects. The first is an add-in that automatically creates the code necessary to build an empty replica of a selected Access database, including creating the database, tables, fields, etc. The second project dbCoderEXE.vbp uses the add-in and will eith save code create from it to the clipboard or to a standard module (.bas file). There are README files for both projects; you must read them before using the projects.

Version 1.31 was added to the site on 05/26/00, and contains a numbe of enhancements, including improved index/relation handling and support for QueryDefs.

Instructions: Click the link below to download the code. Select 'Save' from the IE popup dialog. Once downloaded, open the .zip file from your local drive using WinZip or a comparable program to view the contents.

DOWNLOAD NOW!!!

Quick and Dirty ASP.NET Message Box

Version Compatibility: ASP.NET

More information: In ASP.NET, you cannot use the MessageBox class or MsgBox function like you can in a windows.forms application, but you can emulate this functionality by streaming out a javascript alert instruction. This function can dropped into any ASP.NET code behind module and used for this purpose.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Public Sub ASPNET_MsgBox(ByVal Message As String)

System.Web.HttpContext.Current.Response.Write("")

End Sub

Handle Database Null Values in VB.NET/ASP.NET

Version Compatibility: Visual Basic.NET, ASP.NET

More information: Handling null values returned from database resultsets is different in .NET from VB6, and the documentation is not that clear on how to do it. The first of these functions returns true if such a value is null, the second converts the value to an empty string if it is null.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Public Function IsDBNull(ByVal dbvalue) As Boolean
Return dbvalue Is DBNull.Value
End Function

Public Function FixNull(ByVal dbvalue) As String
If dbvalue Is DBNull.Value Then
Return ""
Else
'NOTE: This will cast value to string if
'it isn't a string.

Return dbvalue.ToString
End If
End Function

Export a DAO Recordset to an Excel Spreadsheet

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: Requires a reference to DAO and Microsoft Excel Object Library Version 9.0 (the one that ships with Excel 2000). Will also work with Excel 8.0 object library (Excel 97), except for some of the file formats specified. If you have Excel 97, change the to formats to match those in the 8.0 library or use the default values as parameters.

Instructions: Copy the declarations and code below and paste directly into your VB project.\

Sub SaveAsExcel(ByVal rs As DAO.Recordset, ByVal filename _
As String, Optional Ffmt As XlFileFormat = xlWorkbookNormal, _
Optional bHeaders As Boolean = True)
'***********************************************************
' Marko Hernandez
' Dec. 2, 2000
'
' Exports a Recordset data into a Microsoft Excel Sheet and
'then can save as new file
' with a given format such Lotus, Q-Pro, dBase, Text
'
' Arguments:
'
' rs : Recordset object (DAO) containing data.
' filename: Name of the file.
' Ffmt: File Format the default value is the
'MS-Excel current version.
' bHeaders: If true the name of the fields will be inserted
'in the first row of each column.
'

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

'Field object
Dim fd As Field

'Cell count, the cells we can use
Dim CellCnt As Integer

'File Extension Type
Dim Fet As String

Screen.MousePointer = vbHourglass
' Assign object references to the variables. Use
' Add methods to create new workbook and worksheet
' objects.
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add

'Get the field names
If bHeaders Then
CellCnt = 1
For Each fd In rs.Fields
Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Cells(1, CellCnt).Value = fd.Name
xlSheet.Cells(1, CellCnt).Interior.ColorIndex = 33
xlSheet.Cells(1, CellCnt).Font.Bold = True
xlSheet.Cells(1, CellCnt).BorderAround xlContinuous
CellCnt = CellCnt + 1
End Select
Next
End If

'Rewind the rescordset
rs.MoveFirst
i = 2
Do While Not rs.EOF()
CellCnt = 1
For Each fd In rs.Fields
Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Cells(i, CellCnt).Value = _
rs.Fields(fd.Name).Value
'xlSheet.Columns().AutoFit
CellCnt = CellCnt + 1
End Select
Next
rs.MoveNext
i = i + 1
Loop

'Fit all columns
CellCnt = 1
For Each fd In rs.Fields

Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, _
dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Columns(CellCnt).AutoFit
CellCnt = CellCnt + 1
End Select
Next

'Get the file extension
Select Case Ffmt
Case xlSYLK
Fet = "slk"
Case xlWKS
Fet = "wks"
Case xlWK1, xlWK1ALL, xlWK1FMT
Fet = "wk1"
Case xlCSV, xlCSVMac, xlCSVdos, xlCSVWindows
Fet = "csv"
Case xlDBF2, xlDBF3, xlDBF4
Fet = "dbf"
Case xlWorkbookNormal, xlExcel2FarEast, xlExcel3, _
xlExcel4, xlExcel4Workbook, xlExcel5, xlExcel6, _
xlExcel7, xlExcel9795
Fet = "xls"
Case xlHTML
Fet = "htm"
Case xlTextMac, xlTextdos, xlTextWindows, xlUnicodeText, _
xlCurrentPlatformText
Fet = "txt"
Case xlTextPrinter
Fet = "prn"
Case Else
Fet = "dat"
End Select

' Save the Worksheet.
If InStr(1, filename, ".") = 0 Then filename = _
filename + "." + Fet
xlSheet.SaveAs filename, Ffmt

' Close the Workbook
xlBook.Close
' Close Microsoft Excel with the Quit method.
xlApp.Quit

' Release the objects.
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing

Screen.MousePointer = vbDefault
End Sub
''*******************SAMPLE USAGE BELOW***********************
'Private Sub Command1_Click()
' SaveAsExcel Data1.Recordset.Clone(), Text1.Text, _
' Combo1.ItemData(Combo1.ListIndex)
'End Sub



Private Sub Form_Load()
'
' Text1.Text = "C:\New File"
' Combo1.AddItem "Installed Excel Format"
' Combo1.ItemData(Combo1.NewIndex) = xlWorkbookNormal
' Combo1.AddItem "Comma Separated Text"
' Combo1.ItemData(Combo1.NewIndex) = xlCSV
' Combo1.AddItem "Excel 95/97"
' Combo1.ItemData(Combo1.NewIndex) = xlExcel9795
' Combo1.AddItem "Internet Format (HTML)"
' Combo1.ItemData(Combo1.NewIndex) = xlHtml
' Combo1.AddItem "MS-DOS Text"
' Combo1.ItemData(Combo1.NewIndex) = xlTextMSDOS
' Combo1.AddItem "Lotus 123 (WK1)"
' Combo1.ItemData(Combo1.NewIndex) = xlWK1
' Combo1.AddItem "Lotus 123 (WKS)"
' Combo1.ItemData(Combo1.NewIndex) = xlWKS
' Combo1.AddItem "Quattro Pro"
' Combo1.ItemData(Combo1.NewIndex) = xlWQ1
'
' Combo1.ListIndex = 0

End Sub

ASP.NET User control (.ASCX) Demo

Version Compatibility: ASP.NET

More information: This Example illustrate how to create a simple user control (.ascx) and how to use it in .aspx files. This example also shows how to use asp.net validator controls. The asp_net_userctrl.zip file contains address.ascx (the user control), testaddresscontrol.aspx (the aspx page that uses the control), and Address Control Output.html (documentation).

Instructions: Click the link below to download the code. Select 'Save' from the IE popup dialog. Once downloaded, open the .zip file from your local drive using WinZip or a comparable program to view the contents.

DOWNLOAD NOW!!!

Copy Files Using the Win32 API

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: In my testing, there was a bit of a speed difference when copying large files using the FileCopy API function, as compared to built-in VB methods such as the FileCopy method or the FileSystemObject.

Instructions: Copy the declarations and code below and paste directly into your VB project

Option Explicit

Private Declare Function CopyFile Lib "kernel32" _
Alias "CopyFileA" (ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, ByVal bFailIfExists As Long) _
As Long

Public Function APIFileCopy(src As String, dest As String, _
Optional FailIfDestExists As Boolean) As Boolean

'PURPOSE: COPY FILES
'PARAMETERS: src: Source File (FullPath)
'dest: Destination File (FullPath)
'FailIfDestExists (Optional):
'Set to true if you don't want to
'overwrite the destination file if
'it exists

'Returns (True if Successful, false otherwise)

'EXAMPLE:
'dim bSuccess as boolean
'bSuccess = APIFileCopy ("C:\MyFile.txt", "D:\MyFile.txt")

Dim lRet As Long
lRet = CopyFile(src, dest, FailIfDestExists)
APIFileCopy = (lRet > 0)

End Function

Convert a file path to a UNC path

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: This funciton converts a reference to a file or a directory in the standard Windows format (e.g. "H:\MySubDir") to the corresponding UNC format (e.g. \\MyMachine\MyDir\MySubDir"). This is useful when a program running on a workstation has to pass a file or directory reference to another app running on another workstation or when the reference should be stored in a database for use from every application on the network.

Instructions: Copy the declarations and code below and paste directly into your VB project

' #VBIDEUtils#**************************************************
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 6/08/99
' * Time : 10:43
' **************************************************************
' * Comments : Convert a file path to a UNC path
' *
' *
' ********************************************************


' Declares for querying Windows version

Const VER_PLATFORM_WIN32s = 0 'Win32s on Windows 3.1
Const VER_PLATFORM_WIN32_WINDOWS = 1 'Win32 on Windows 95
Const VER_PLATFORM_WIN32_NT = 2 'Win32 on Windows NT

Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "Kernel32" _
Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

' Declare for Registry functions

Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey _
As String, ByVal ulOptions As Long, ByVal samDesired _
As Long, phkResult As Long) As Long

Private Declare Function RegQueryValue Lib "advapi32.dll" Alias _
"RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As _
String, ByVal lpValue As String, lpcbValue As Long) As Long

' Note that if you declare lpData as String, then it is
' necessary to pass it with ByVal
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long

Private Declare Function RegEnumKey Lib "advapi32.dll" _
Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex _
As Long, ByVal lpName As String, ByVal cbName As Long) _
As Long

Private Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex _
As Long, ByVal lpValueName As String, lpcbValueName _
As Long, ByVal lpReserved As Long, lpType As Long, _
ByVal lpData As String, lpcbData As Long) As Long

Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function GetComputerName Lib "Kernel32" _
Alias "GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long

Private Declare Function WNetGetConnection Lib _
"mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName _
As String, ByVal lpszRemoteName As String, _
cbRemoteName As Long) As Long

' Private function that does the work under Windows NT
Private Function GetUNCNameNT(pathName As String) As String

Dim hKey As Long
Dim hKey2 As Long
Dim exitFlag As Boolean
Dim i As Double
Dim ErrCode As Long
Dim rootKey As String
Dim key As String
Dim computerName As String
Dim lComputerName As Long
Dim stPath As String
Dim firstLoop As Boolean
Dim ret As Boolean

' first, verify whether the disk is connected to the network
If Mid(pathName, 2, 1) = ":" Then
Dim UNCName As String
Dim lenUNC As Long

UNCName = String$(520, 0)
lenUNC = 520
ErrCode = WNetGetConnection(Left(pathName, 2), UNCName, lenUNC)

If ErrCode = 0 Then
UNCName = Trim(Left$(UNCName, InStr(UNCName, _
vbNullChar) - 1))
GetUNCNameNT = UNCName & Mid(pathName, 3)
Exit Function
End If
End If

' else, scan the registry looking for shared resources
'(NT version)
computerName = String$(255, 0)
lComputerName = Len(computerName)
ErrCode = GetComputerName(computerName, lComputerName)
If ErrCode <> 1 Then
GetUNCNameNT = pathName
Exit Function
End If

computerName = Trim(Left$(computerName, InStr(computerName, _
vbNullChar) - 1))
rootKey = "SYSTEM\CurrentControlSet\Services\LanmanServer\Shares"
ErrCode = RegOpenKey(HKEY_LOCAL_MACHINE, rootKey, hKey)

If ErrCode <> 0 Then
GetUNCNameNT = pathName
Exit Function
End If

firstLoop = True

Do Until exitFlag
Dim szValue As String
Dim szValueName As String
Dim cchValueName As Long
Dim dwValueType As Long
Dim dwValueSize As Long

szValueName = String(1024, 0)
cchValueName = Len(szValueName)
szValue = String$(500, 0)
dwValueSize = Len(szValue)

' loop on "i" to access all shared DLLs
' szValueName will receive the key that identifies an element
ErrCode = RegEnumValue(hKey, i#, szValueName, _
cchValueName, 0, dwValueType, szValue, dwValueSize)

If ErrCode <> 0 Then
If Not firstLoop Then
exitFlag = True
Else
i = -1
firstLoop = False
End If
Else
stPath = GetPath(szValue)
If firstLoop Then
ret = (UCase(stPath) = UCase(pathName))
stPath = ""
Else
ret = (UCase(stPath) = UCase(Left$(pathName, _
Len(stPath))))
stPath = Mid$(pathName, Len(stPath))
End If
If ret Then
exitFlag = True
szValueName = Left$(szValueName, cchValueName)
GetUNCNameNT = "\\" & computerName & "\" & _
szValueName & stPath
End If
End If
i = i + 1
Loop

RegCloseKey hKey
If GetUNCNameNT = "" Then GetUNCNameNT = pathName

End Function

' support routine

Private Function GetPath(st As String) As String
Dim pos1 As Long, pos2 As Long, pos3 As Long
Dim stPath As String

pos1 = InStr(st, "Path")
If pos1 > 0 Then
pos2 = InStr(pos1, st, vbNullChar)
stPath = Mid$(st, pos1, pos2 - pos1)
pos3 = InStr(stPath, "=")
If pos3 > 0 Then
stPath = Mid$(stPath, pos3 + 1)
GetPath = stPath
End If
End If
End Function