Sign In Sign-Up

Welcome!

Close

Would you like to make this site your homepage? It's fast and easy...

Yes, Please make this my home page!

No Thanks

  Don't show this to me again.

Close

CONTROLS

=======================================================================
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
Next

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

Const LB_SETHORIZONTALEXTENT = &H194

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
Const LB_SETTABSTOPS = &H192

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
Else
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
Else
FindString = True
Control.SetFocus
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
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2

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

DATABASE

=======================================================================
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
DoEvents
Loop

=======================================================================
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

PRINTING

=======================================================================
' 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
Printer.NewPage
Next
Next
Printer.EndDoc

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
Printer.Enddoc
MSGrid.Width = old_width

INTERNET

=======================================================================
Print the contents of the WebBrowser control

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

WebBrowser1.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER

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

s=WebBrowser1.Document.All(0).OuterHTML

GRAPHICS

=======================================================================
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

SYSTEM

=======================================================================
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
Dim wp As WINDOWPLACEMENT

' 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.
wp.showCmd = SW_SHOWMINIMIZED
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
DoEvents

' 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:="", _
Format:=wdOpenFormatAuto

' Go to the bookmark.
WordServer.Selection.GoTo _
What:=wdGoToBookmark, _
Name:="Disclaimer"
WordServer.Selection.Find.ClearFormatting
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.Clear
Clipboard.SetData Picture1.Picture, vbCFBitmap

' Paste the image into Word.
WordServer.Selection.Paste

' 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

STRING MANIPULATION

=======================================================================

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
Do
If (I > Len(Source)) Then Exit Do
I = InStr(I, Source, Countee, vbTextCompare)
If I Then
iCount = iCount + 1
I = I + 1
DoEvents
End If
Loop While I
sCount = iCount
Exit Function
CountError:
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)
Else
For x = Len(Code) To 4
Code = Code + "0"
Next x
End If
SoundEx = Code
End Function