Determine if a type of control is in a type of a container

Public Function ContrIsInCont(usedControl As Control, usedContainer As Control) As Boolean

fillfields = False
For Each objControl In Controls
    If TypeOf objControl Is usedControl Then
        If objControl.Container Is usedContainer Then
            fillfields = True
        End If
    End If

End Function

end function

Programmatically add a label to the form and set its caption

Dim objControl As Label
Set objControl = Controls.Add("VB.Label", "lblNewLabel", Me)
With objControl
    .Caption = "Add a label"
    .Left = 100
    .Top = 100
    .Visible = True
End With

Find text in a combo box

Public Function ComboBoxIndex(ByVal lHwnd As Long, ByVal sSearchText As String) As Long
     ComboBoxIndex = SendMessageAny(lHwnd, CB_FINDSTRING, -1, ByVal sSearchText)
End Function


Adding a horizontal scroll bar to a listbox


Dim hSize As Long
hSize = 350
Call SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, hSize, ByVal 0&)

Search listbox for a string

Public Function ListBoxIndex(ByVal lHwnd As Long, ByVal sSearchText As String) As Long
ListBoxIndex = SendMessageAny(lHwnd, LB_FINDSTRING, -1, ByVal sSearchText)
End Function

Set tab stops in listbox

Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function GetDialogBaseUnits Lib "USER32" () As Long

Sub SetTabStops(lListWindowHandle As ListBox, iNoTabStops As Integer, lTabPositions() As Long)
Dim iIndex As Integer
Dim lDialogBaseUnits As Long
Dim iDialogUnitsX As Integer
lDialogBaseUnits = GetDialogBaseUnits()
iDialogUnitsX = (lDialogBaseUnits And &HFFFF&) \ 4
ReDim lTabPos(0 To iNoTabStops - 1) As Long
For iIndex = 0 To iNoTabStops - 1
lTabPos(iIndex) = lTabPositions(iIndex) * iDialogUnitsX * 2
Next iIndex
Call SendMessage(lListWindowHandle.hWnd, LB_SETTABSTOPS, CLng(iNoTabStops), lTabPos(0))
End Sub

Place a progress bar in a status bar panel

'Note: Place a status bar and a progress bar on a form and make the progress bar invisible

'Module Declares
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Const WM_USER = &H400
Public Const SB_GETRECT = (WM_USER + 10)

Private Sub ShowProgress(Mode As Boolean)
Dim rc As RECT
StatusBar1.Panels("keyProgress").Visible = Mode
If Mode Then
SendMessageAny StatusBar1.hwnd, SB_GETRECT, 2, rc
With rc
.Top = .Top * Screen.TwipsPerPixelY
.Left = .Left * Screen.TwipsPerPixelX
.Bottom = .Bottom * Screen.TwipsPerPixelY - .Top
.Right = .Right * Screen.TwipsPerPixelX - .Left
End With'
With ProgressBar1
SetParent .hwnd, StatusBar1.hwnd
.Move rc.Left, rc.Top, rc.Right, rc.Bottom
.Visible = True
.Value = 0
End With
SetParent ProgressBar1.hwnd, Me.hwnd
ProgressBar1.Visible = False
End If

End Sub

Find a string in a textbox and highlight

Private Function FindString (Control As Control, FindStr As String, Optional StartPos As Integer = 1 ) As Boolean
Dim a As Integer
a = InStr(StartPos, LCase$(Control.Text), LCase$(FindStr))
If a = 0 Then
FindString = False
FindString = True
Control.SelStart = a - 1
Control.SelLength = Len(FindStr)
End If
End Sub

Drag a control at runtime

Private Declare Function ReleaseCapture Lib "user32" () As Long
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

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
SendMessage Picture1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub


Connect to SQL Server and MSDE hosts

Dim SQLServer As SQLDMO.SQLServer
Set SQLServer = New SQLDMO.SQLServer
SQLServer.Name = "<SQL Server's Host Name Here>"
If SQLServer.Status = SQLDMOSvc_Stopped Then
SQLServer.Start False, SQLServer.Name
End If
Do While SQLServer.Status = SQLDMOSvc_Starting
Sleep 500

Start SQL Server 2000 automatically

Dim SQLServer As SQLDMO.SQLServer2
Set SQLServer = New SQLDMO.SQLServer2
SQLServer.Name = "server"
SQLServer.LoginSecure = False
SQLServer.Connect "server", "sa"
SQLServer.AutoStart = True

Build a connection string

Function ConString(Server, UserName, Password, Database, Lib) As String

if Lib = "" then lib = "SQLOLEDB"
ConString = "PROVIDER=" & LIB & ";driver={SQL Server};server=" & Server &
";uid=" & UserName & ";pwd=" & Password & ";database=" & Database & ";"

End Function




' Print a big picture on four pages.
Private Sub cmdPrint_Click()
Const PAGE_WIDTH = 8.5 * 1440
Const PAGE_HEIGHT = 11 * 1440
Dim intRow As Integer
Dim intColumn As Integer

For intRow = 0 To 1
For intColumn = 0 To 1
With Printer
.ScaleLeft = intRow * PAGE_WIDTH
.ScaleTop = intColumn * PAGE_HEIGHT
.ScaleWidth = PAGE_WIDTH
.ScaleHeight = PAGE_HEIGHT
End With

DrawPicture Printer

End Sub

Loop through the Printers collection until your find the printer you want.

' Return False if there is a problem.
Private Function SelectPrinter(ByVal printer_name As String) As Boolean
Dim i As Integer

SelectPrinter = False
For i = 0 To Printers.Count - 1
If Printers(i).DeviceName = printer_name Then
Set Printer = Printers(i)
SelectPrinter = True
Exit For
End If
Next i
End Function

Print a FlexGrid

Dim old_width As Integer

old_width = MSGrid.Width
MSGrid.Width = Printer.Width
Printer.paintpicture MSGrid.picture, 0, 0
MSGrid.Width = old_width



Print the contents of the WebBrowser control

Call the browser's ExecWB method with the OLECMDID_PRINT flag as in:


Get HTML with the Microsoft Internet Control
The following code will return all the HTML in a document:




Convert WMF Files Into BMP Files

' Load meta picture file
Picture1.Picture = LoadPicture("filename.wmf")

' Save meta picture to bitmap file
SavePicture Picture1.Image, "filename.bmp"

Make a bitmap of a FlexGrid

Me.picturebox1.picture = MSGrid.picture


Find a window using its title and minimize it

Use the FindWindow API function to find the window's handle. Then use the
SetWindowPlacement API function to minimize it.

' Find the target window and minimize it.
Private Sub cmdMinimizeWindow_Click()
Dim app_hwnd As Long

' Find the target.
app_hwnd = FindWindow(vbNullString, txtTargetName.Text)

' Get the window's current placement information.
wp.length = Len(wp)
GetWindowPlacement app_hwnd, wp

' Minimize the window.
SetWindowPlacement app_hwnd, wp
End Sub


Paste an image into a Word file

Private Sub Command1_Click()
Dim file_name As String
Dim file_path As String
Dim file_title As String
Dim txt As String
Dim new_txt As String
Dim pos As Integer

Screen.MousePointer = vbHourglass
Command1.Enabled = False

' Open Word.
file_name = txtFilename.Text
file_title = Mid$(file_name, InStrRev(file_name, "\") + 1)
file_path = Left$(file_name, Len(file_name) - Len(file_title))

' Uncomment to show Word.
' WordServer.Visible = True

WordServer.ChangeFileOpenDirectory file_path
WordServer.Documents.Open _
FileName:=file_title, _
ConfirmConversions:=False, _
ReadOnly:=False, _
AddToRecentFiles:=False, _
PasswordDocument:="", _
PasswordTemplate:="", _
Revert:=False, _
WritePasswordDocument:="", _
WritePasswordTemplate:="", _

' Go to the bookmark.
WordServer.Selection.GoTo _
What:=wdGoToBookmark, _
With WordServer.Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

' Copy the image to the clipboard.
Clipboard.SetData Picture1.Picture, vbCFBitmap

' Paste the image into Word.

' Comment out to keep Word running.
WordServer.Quit True
Set WordServer = Nothing

Screen.MousePointer = vbDefault
Command1.Enabled = True
End Sub

Calculate the number of days in a month

Private Sub cmdGo_Click()
Dim month_number As Integer
Dim year_number As Integer

month_number = Month(txtMonth.Text)
year_number = Year(txtMonth.Text)
MsgBox "Days: " & Format$(Day(DateSerial(year_number, month_number + 1, 0)))
End Sub



Zero Fill a Field

Private Sub txtTestField_LostFocus()
Me.txtTestField.Text = Right(String(intFieldLength, "0") & Me.txtTestField.Text, intFieldLength)
End Sub



Count the number of string occurrences

Public Function Count(Source As String, Countee As String) As Long
Dim I As Long, iCount As Integer
iCount = 0
I = 1
If (I > Len(Source)) Then Exit Do
I = InStr(I, Source, Countee, vbTextCompare)
If I Then
iCount = iCount + 1
I = I + 1
End If
Loop While I
sCount = iCount
Exit Function
sCount = 0
Exit Function
End Function

Soundex String Conversion

Public Function SoundEx(sString As String) As String

Dim x As Long
Dim CharCode As String * 1
Dim Code As String
Const SOUNDEX_ALPHABET = "01230120022455012623010202"
sString = UCase(sString)
Code = Left$(sString, 1)
sString = Right$(sString, Len(sString) - 1)
For x = 1 To Len(sString)
CharCode = Mid$(SOUNDEX_ALPHABET, Asc(Mid$(sString, x)) - 64)
If (Val(CharCode) And CharCode <> Mid$(Code, Len(Code))) Then _
Code = Code + CharCode
Next x
If Len(Code) >= 5 Then
Code = Left$(Code, 5)
For x = Len(Code) To 4
Code = Code + "0"
Next x
End If
SoundEx = Code
End Function