K&K Home
Up
Check For Good Friday
Credit Card Numbers
VB Home

VB Code Snippets

Name & Date	Code Description	Code
May 05, 2001	If you need to create a delay in your ASP/HTML page, client or Server, then this is the code for you. Note, I have posted it as server code, but it can very easily be modified for client or HTML side.	Create A Delay In HTML Pages <% Sub TLdelaySec(DelaySeconds) SecCount = 0 Sec2 = 0 While SecCount < DelaySeconds + 1 Sec1 = Second(Time()) If Sec1 <> Sec2 Then Sec2 = Second(Time()) SecCount = SecCount + 1 End If Wend End Sub %> <% TLdelaySec(2) %>
May 01, 2001	Create Classes in ASP? That's right, I discovered this snippet of code by accident. I have searched the MSDN files, both from the latest CD and on-line; I could not find a reference to it any ware. I have spoke to a few ASP developers and no one has heard of creating Classes in ASP!!!! I have created a small class with properties and a method to show you how to do it.	ASP Classes <header> </header> <body> <% Class clsUsers Dim ID Public Property Let UserID(IDNum) ID = IDNum End Property Public Property Get UserID() UserID = ID End Property Public function PrintID () PrintID = "My UserID Is: " & UserID End Function End Class %> <% Sub Users(NumOfUsers) Dim User() Dim counter Redim User(NumOfUsers) For counter = 0 to NumOfUsers set User(counter) = new clsUsers With user(counter) .UserID = counter End with Next For counter = 0 to NumOfUsers With user(counter) response.Write .printID & "<br>" End with Next For counter = 0 to n set user(counter) = nothing Next End Sub %> <% Users(20) %> </body>
April 25, 2001	Its primary purpose is to ensure accurate entries of the credit card number during transactions.	Ensure Accurate Credit Card Numbers Click Here To See The Code
April 25, 2001	Determines whether the day is Good Friday	Check For Good Friday Click Here To See The Code
April 20, 2001	Encryption made easy for ASP Pages	<% Function CryptVBS(Text, Key) KeyLen = Len(Key) For i = 1 To Len(Text) KeyPtr = (KeyPtr + 1) Mod KeyLen sTxtChr = Mid(Text, i, 1) wTxtChr = Asc(stxtchr) wKeyChr = Asc(Mid(Key, KeyPtr + 1, 1)) CryptKey = Chr(wTxtChr Xor wKeyChr) hold = hold & CryptKey Next CryptVBS = hold End Function %>
Feb 23, 2001	Find That Long Pathname	Option Explicit '~modGetLongPath.bas; 'Return the longpath of a shortpath specification '************************************************************************ *** ' modGetLongPath - The GetLongPath() function returns the longpath version of a ' filepath or dirpath that is formatted in the 8.3 shortpath ' format. 'EXAMPLE: ' Debug.Print GetLongPath("C:\Progra~1\Common~1\micros~1\webser~1") ''' This will print: ''' C:\Program Files\Common Files\Microsoft Shared\Web Server Extensions ' 'NOTE: This module requires a reference to Microsoft Scripting Runtime (Scrrun.dll) '********************************************************************** ***** Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" _ (ByVal lpszLongPath As String, _ ByVal lpszLongPath As String, _ ByVal cchBuffer As Long) As Long Public Function GetLongPath(InPath As String) As String Dim fso As FileSystemObject, fold As Folder, fil As File Dim S As String, I As Integer, j As Integer, drv As String, tmp As String Dim SS As String S = Trim$(InPath) 'get the trimmed form of path drv = String(260, 0) 'receiving buffer On Error Resume Next I = GetLongPathName(S, drv, 260) 'get buffer to drv, len to I If Err.Number = 0 Then 'not win98/ME/2000 GetLongPath = Left$(drv, I) 'return path if no error Exit Function End If On Error GoTo 0 ' ' win Nt4.0/95 or below, so do it with an FSO ' drv = "" 'blank in case not existing If Len(Dir(S)) Or Len(Dir(S, vbDirectory)) Then 'file/dir exists drv = S 'init to full path ' ' check for short stuff existing ' If InStr(1, S, "~") Then 'short stuff in there? drv = "" 'yes, so yank sort path Set fso = New FileSystemObject 'set up pathing object If Left$(S, 2) = "\\" Then 'UNC path? I = InStr(3, S, "\") 'yes, skip device name If I Then j = InStr(I + 1, S, "\") 'then skip drive name If j Then I = j End If Else I = InStr(3, S, "\") 'else just skip drive End If If I Then 'drivepath specified? drv = Left$(S, I) 'get drive S = Mid$(S, I + 1) 'get stuff after End If ' ' step through directory data ' I = InStr(I + 1, S, "\") 'a subdir path? Do While I tmp = LCase$(Left$(S, I - 1)) 'yes, get subdir name j = InStr(tmp, "~") 'short name? If j Then 'yes, find full name SS = Dir(drv & Left$(tmp, j - 1) & "", vbDirectory) Do While Len(SS) Set fold = fso.GetFolder(drv & SS) 'get folder for long path If LCase$(fold.ShortName) = tmp Then Exit Do 'found short version SS = Dir() 'else get next Loop Else SS = tmp 'not short, so keep full name End If drv = drv & SS & "\" 'set new base path S = Mid$(S, I + 1) 'trimp off prev dir I = InStr(1, S, "\") 'check for another Loop ' ' handle stuff left over ' If Len(S) Then j = InStr(1, S, "~") 'last item short? If j Then 'yes SS = Dir(drv & Left$(S, j - 1) & "", vbDirectory) If Len(SS) Then 'was a directory Do While Len(SS) 'get full path Set fold = fso.GetFolder(drv & SS) If LCase$(fold.ShortName) = S Then Exit Do SS = Dir() 'never blank unless it's a file Loop End If If Len(SS) = 0 Then 'file? SS = Dir(drv & Left$(S, j - 1) & "*") 'yes, check matching files Do While Len(SS) Set fil = fso.GetFile(drv & SS) 'check for matching shortname If LCase$(fil.ShortName) = S Then Exit Do SS = Dir() 'else check next Loop End If Else SS = S 'keep full name if noth short End If End If If Len(SS) Then drv = drv & SS 'build full long path Set fso = Nothing 'remove object End If End If GetLongPath = drv 'return result End Function

Oct 11,2000	A very cool 3d text. Test it!!!! :-)	'******************Place This Code in a Cammand Button******* Dim i, x, y ' ************************************** Me.FontSize = 26 ' ************************************** Me.ForeColor = 0: x = CurrentX: y = CurrentY ' ************************************** For i = 0 To 444 Print "Netrom Software" ' Here goes your text. x = x + 1: y = y + 1: CurrentX = x: CurrentY = y Next i ' ************************************** Me.ForeColor = 255 Print "Netrom Software" ' **************************************** ' This is made by Morten D Carlsson ' www.fly.to/netrom ' mor_d_ca@hotmail.com
July 12,2000	This is the alpha equivalent to IsNumeric. Returns a true if accepted characters are found while looping through the string.	'******************************************************** 'IsAlpha - locate illegal charactes in the subject field Public Function IsAlpha(strText As String) As Boolean Dim intLen As Integer Dim intCounter As Integer Dim blnAlpha As Boolean Dim strChar As String intLen = Len(strText) 'Set the condition of our loop For intCounter = 1 To intLen strChar = Mid(strText, intCounter, 1) 'Accept A through z" If strChar >= "A" And strChar <= "z" Then blnAlpha = True Else 'Accept "spaces", "periods", and "commas" If strChar = " " Or strChar = "." Or strChar = "," Then blnAlpha = True 'Reject everything else. Else blnAlpha = False End If End If 'We caught an illegal character (not A-z, " ", ".", or "," If blnAlpha = False Then IsAlpha = False Exit Function End If Next intCounter IsAlpha = True End Function
July 08,2000	Under Windows 2000 and Windows 98 their is a function called AnimateWindow. AnimateWindow lets you hide and show windows and specify an animation to occur as this happens.	' #VBIDEUtils#************************************************ ' * Programmer Name : Waty Thierry ' * Web Site : www.geocities.com/ResearchTriangle/6311/ ' * E-Mail : waty.thierry@usa.net ' * Date : 20/09/1999 ' * Time : 12:06 ' ************************************************************ ' * Comments : Animating Windows ' * ' * Under Windows 2000 and Windows 98 their is a function called ' * AnimateWindow. AnimateWindow lets you hide and show windows ' * and specify an animation to occur as this happens. ' * ' ************************************************************* Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd _ As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Long Private Const AW_HOR_POSITIVE = &O1 ' Animate the window from 'left to right. This flag can be used with roll or slide 'animation It is ignored when used with the AW_CENTER flag. Private Const AW_HOR_NEGATIVE = &H2 ' Animate the window from 'right to left. This flag can be used with roll or slide 'animation. It is ignored when used with the AW_CENTER flag. Private Const AW_VER_POSITIVE = &H4 ' Animate the window from 'top to bottom. This flag can be used with roll or slide 'animation. It is ignored when used with the AW_CENTER flag. Private Const AW_VER_NEGATIVE = &H8 ' Animate the window from 'bottom to top. This flag can be used with roll or slide 'animation. It is ignored when used with the AW_CENTER flag. Private Const AW_CENTER = &H10 ' Makes the window appear to 'collapse inward if the AW_HIDE flag is used or expand outward 'if the AW_HIDE flag is not used. Private Const AW_HIDE = &H10000 ' Hides the window. By default, 'the window is shown. Private Const AW_ACTIVATE = &H20000 ' Activates the window. Do 'not use this flag with AW_HIDE. Private Const AW_SLIDE = &H40000 ' Uses slide animation. By 'default, roll animation is used. This flag is ignored when used 'with the AW_CENTER flag. Private Const AW_BLEND = &H80000 ' Uses a fade effect. This flag 'can be used only if hwnd is a top-level window. Code: ' * To make a form collapse inward and then disappear use: AnimateWindow myForm.hwnd, 500, AW_CENTER Or AW_HIDE ' * To make a form expand outwards and become active use: AnimateWindow myForm.hwnd, 500, AW_CENTER Or AW_ACTIVATE ' * For this to work the form must be invisible. ' * Other effects can be achieved by combining flags, for 'example to make a form to become visible diagonally use: AnimateWindow hwnd, 500, AW_HOR_POSITIVE Or AW_VER_POSITIVE
July 08,2000	This function will clear the list of recent documents you see when you click the Start Button and then Documents.	Option Explicit Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal PV As String) Public Function ClearDocumentsMenu() As Boolean 'Returns true if successful, false otherwise SHAddToRecentDocs 2, vbNullString ClearDocumentsMenu = Err.LastDllError = 0 End Function

June 25,2000	Read & Write to the Registry	Dim Text As String 'Gets from the registry Print GetSetting(App.Title, "Startup", "Message", "Hello") 'Saves to the registry Text = "Hello again!!!" SaveSetting App.Title, "Startup", "Message", Text 'Deletes from the registry DeleteSetting App.Title, "Startup", "Message"
June 25,2000	Deactivate the Screen Saver	' Declarations Private Const SPIF_SENDWININICHANGE = &H2 Private Declare Function SystemParametersInfo Lib "user32" _ Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal _ uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As _ Long) As Long 'Code: Public Function ToggleScreenSaverActive(Active As Boolean) _ As Boolean 'To Activate Screen Saver, set active to true 'to deactivate, set active to false Dim lActiveFlag As Long Dim retval As Long lActiveFlag = IIf(Active, 1, 0) retval = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, _ lActiveFlag, 0, 0) ToggleScreenSaverActive = retval > 0 End Function
June 25,2000	Scroll your program to the left on unload.	1) add a Timer. Place this code on the Timer: Private Sub Timer1_Timer() Form.Move Form.Left - 300 If Form.Left < -Form.Width Then End End Sub Place this code on the Form_Unload action: Private Sub Form_Unload() Timer1.Interval = 1 End Sub If you are not using the custom close controls, add a Label and add this code to the Label: Private Sub Label_Click() Timer1.Interval = 1 End Sub
June 25,2000	A simple demonstration of saving/loading files with "get" and "put" commands. This program let you generate a number, then let you save/load it. The file it created cannot be read by other programs or notepad. you can save/load as many things as you want, just add more lines: put #1, , variable get #1, , variable	' you'll need a label and 3 command buttons, call them cmdSave, cmdLoad, cmdAdd 'U will also need to declare a form Var called Counter1 as Double sub cmdAdd_Click () ' add 1 to the counter and display it on a label counter1 = counter1 + 1 label1.Caption = counter1 end sub sub cmdSave_Click () Dim strFn as string ' gets filename from user strFn = UCase$(Trim$(Inputbox$("Save as...", "Filename"))) ' writes on file Open strFn for Binary Access Write as #1 put #1, , counter1 Close #1 end sub sub cmdLoad_Click () Dim strFn as string ' gets filename from user strFn = UCase$(Trim$(Inputbox$("Load as...", "Filename"))) ' reads from file Open strFn for Binary Access Read as #1 get #1, , counter1 Close #1 end sub

The Guru June 07,2000	Find the First day in a Week	Function dhFirstDayInWeek(Optional dtmDate As Date = 0) As Date ' Returns the first day in the week specified ' by the date in dtmDate. ' Uses localized settings for the first day of the week. If dtmDate = 0 Then ' Did the caller pass in a date? If not, use ' the current date. dtmDate = Date End If dhFirstDayInWeek = dtmDate - WeekDay(dtmDate, _ vbUseSystem) + 1 End Function
The Guru June 07,2000	Find the Last day in a Week	Function dhLastDayInWeek(Optional dtmDate As Date = 0) As Date ' Returns the last day in the week specified by ' the date in dtmDate. ' Uses localized settings for the first day of the week. If dtmDate = 0 Then ' Did the caller pass in a date? If not, use ' the current date. dtmDate = Date End If dhLastDayInWeek = dtmDate - WeekDay(dtmDate, vbUseSystem) + 7 End Function
The Guru June 05,2000 Posted from Microsoft Site	You can use the following small piece of code to detect the current screen resolution and then act on the information - for instance, by resizing form objects to suit the user's resolution.	Dim x As integer Dim y As Integer x = Screen.Width / 15 y = Screen.Height / 15 If x = 640 And y = 480 Then MsgBox ("640 * 480") If x = 800 And y = 600 Then MsgBox ("800 * 600") If x = 1024 And y = 768 Then MsgBox ("1024 * 768")
The Guru June 05,2000	To put a Animated GIF on your VB form, do the following: Place a web control on your form and insert this code.	WebBrowser1.Navigate "about:<html><body scroll='no'><img src='D:\Internet\anim.gif'></img></body></html>"

Send mail to WebMaster with questions or comments about this web site.
This website is best viewed with a screen resolution of 800*600 or better.
This website is optimized for Microsoft Internet Explorer 6.x
K&K Consulting, Proud to be a Microsoft Business Partner.

VB Code Snippets

Name & Date

Code Description

Code

Create A Delay In HTML Pages

ASP Classes

Ensure Accurate Credit Card Numbers

Check For Good Friday

Send mail to WebMaster with questions or comments about this web site. This website is best viewed with a screen resolution of 800*600 or better.This website is optimized for Microsoft Internet Explorer 6.x K&K Consulting, Proud to be a Microsoft Business Partner.

Last modified: January 31, 2002

Send mail to WebMaster with questions or comments about this web site.
This website is best viewed with a screen resolution of 800*600 or better.
This website is optimized for Microsoft Internet Explorer 6.x
K&K Consulting, Proud to be a Microsoft Business Partner.