My Favourite code snippets Part 1

And here's your host for tonight: Jop

Hi Ladies and Gentlemen,
here we are with another oh-so-cool :cool: episode of the My Favourite * series, if you don't know what I'm talking look at: http://forums.vb-world.net/showthrea...threadid=28301, http://www.vb-world.net/beginning/functions3/, http://www.vb-world.net/beginning/functions2/ and http://www.vb-world.net/beginning/functions/.

No pre-made VB functions this time, but code snippets!
I want to make a huge collection of small code snippets to do various tasks.
It doesn't have to do complicated things, but it has to work, please test it before posting.
Please respect the original author of the code, and tell where you got the code from, please don't post any copyrighted code here.
Please post it in the following format so I can use it with my code-snippet-program:

Code:

---

'[Begin of code]
'Author: <authorname>
'Origin: <wheredidyougotitfrom?>
'Purpose of the code
'For wich VB version intended (VB5/VB6)

'<the code itself>

'[end of code]

---

Thanks for your attention ladies and gentlemen, let the coding begin!

(i'll come back later with a few of my own favourite code snippets.)

[Edited by Jop on 09-25-2000 at 10:43 AM]

Have fun! Um, I think. :rolleyes:

Code:

---

'[Begin of code]
'Author: Yonatan
'Origin: Brain
'Purpose: Cut the nulls from the end of a string: Useful for strings returned by API functions
'Version: VB5+ (I think)

Option Explicit

' Function version and sub version... Use the one which looks more fun! :rolleyes:
#Const FunctionVersion = True ' Change to False to use the Sub version

#If FunctionVersion Then
Function TrimNulls(ByVal sString As String) As String
#Else
Sub TrimNulls(sString As String)
#End If
    Dim lPos As Long
   
    lPos = InStr(sString, vbNullChar)
   
    If lPos > 0 Then sString = Left(sString, lPos - 1)
#If FunctionVersion Then
    TrimNulls = sString
End Function
#Else
End Sub
#End If

'[end of code]

---

Usage:

Code:

---

Dim sString As String, lSize As Long

lSize = 256 ' Or any other number

sString = String(lSize, vbNullChar)
Call SomeRandomAPIFunction(sString, lSize)

' Function:
sString = TrimNulls(sString)
' Sub:
Call TrimNulls(sString)

---

Enjoy, if possible! :rolleyes:

Here's one of my all-time-favourites:

Code:

---

'[begin of code]
'Author: John Percival
'Origin: http://www.vb-world.net/tips/tip110.html
'Purpose: A Find-and-Replace function for VB5 users
'Version: VB5+

Public Function replaceall(searchstring As String, _
findstring As String, replacestring As String) As String

Dim curpos As Long

curpos = 1

Do

curpos = InStr(curpos, searchstring, findstring)
searchstring = Left$(searchstring, curpos - 1) & _
replacestring & Right$(searchstring, Len(searchstring) _
- curpos - Len(findstring) + 1)

Loop Until InStr(searchstring, findstring) = 0

replaceall = searchstring

End Function

'[end of code]

---

More to come my friends!

Jop: You say No Functions and then you paste one...

The function you posted is now a VB6 Function:

Code:

---

'replace function in VB6
'find an instance and replace it with another

Private Sub Form_Load()
    string1 = "my name:: is nowhere:: to be found!"
    string2 = Replace(string1, "::", ":")
    msgbox string2 
End Sub

---

HeSaidJoe, when I said no functions I meant no pre-made functions from the VB Language.
I know it's a pre-made function in VB6, but it's still a code-snippet for our VB5 users (I'm one of them).
I'll edit the mainpost.


Here's some more code

Code:

---

'[begin of code]
'Author: Jop
'Origin: Inspired by some post on this forum (can't remember who)
'Purpose: Show or hide a window without unloading it.
'Version: VB5+

'Api calls
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Dim Myhwnd As Long, showme As Integer
Private Sub ShowHideWindow(Classname As String, WindowCaption As String, Show As Boolean)
If Classname = "" Then Classname = vbNullString
If WindowCaption = "" Then WindowCaption = vbNullString
'Find the window by either his classname or caption
    Myhwnd = FindWindow(Classname, WindowCaption)
'if found
    If Myhwnd <> 0 Then
    If Show = True Then
    showme = 5
    Else
    showme = 0
    End If
'Show or hide the window
    ShowWindow Myhwnd, showme
    End If
End Sub

'Usage:
'ShowHideWindow "MYHANDLE", "MYCAPTION", True/False
'[end of code]

---

[Edited by Jop on 09-25-2000 at 10:59 AM]

Sorry, I should have put a LOL behind the line. Don't mind me I have a dry sense of humor. Functions are useful and this is your post.

This snippet is not the most useful thing but can give you an entrance as a splach screen.
[code]
' <Author>
' Unknown
' <Origin>
' this code creates a starburst effect on the form
' taken from a Q & A On Expert's Exchange...Posted: dlwulfe
' originally from some book, so says dlwulfe
' <Purpose>
' Draws a starburst effect on a form (Dazzeling)
'
' In VB5, lines drawn on the form will draw over an Image control.
' If you want to draw over a PictureBox, or any other control,
' set the ClipControls property of the form to False.
' For wich VB version intended (VB5/VB6)

'

Code:

---


Option Explicit

Private Sub Form_Load()
    Timer1.Interval = 74
End Sub

Private Sub Timer1_Timer()

'random lines in random colors

  Dim i As Integer, CCode As Integer
  Dim Col As Single, Row As Single
  WindowState = 0
  Randomize

  Scale (-320, 240)-(320, -240)

  For i = 1 To 100
    Col = 320 * Rnd
    If Rnd < 0.5 Then Col = -Col
    Row = 240 * Rnd
    If Rnd < 0.5 Then Row = -Row
    CCode = 15 * Rnd
    Line (0, 0)-(Col, Row), QBColor(CCode)
  Next i

End Sub

'< End Code >

---

Here's a good one that I found lying around. :rolleyes:
It reads a TextBox (not necessarily a TextBox in your application) and copies all its contents to an array of strings.
The array of strings contains the lines the way they appear in the TextBox.
So, if you have a MultiLine TextBox, in which there are five lines, but no carriage returns or line feeds (technically one long word-wrapped line), the snippet would return an array of five strings.
This is useful for printing a TextBox's contents!

Code:

---

'[begin of code]
'Author: Yonatan
'Origin: My keyboard
'Purpose: Reads a TextBox's contents into a string array
'VB5+, maybe less

Option Explicit

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 Const EM_GETLINE = &HC4
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_LINELENGTH = &HC1
Private Const EM_LINEINDEX = &HBB

Sub GetTextBoxLines(ByVal hText As Long, saLines() As String)
    Dim I As Integer, sLine() As Byte
   
    ' Get the amount of virtual lines in the TextBox (the way you see it, not the way Windows sees it)
    ' Then, start a For-Next loop from 1 to the amount of virtual lines
    For I = 1 To SendMessage(hText, EM_GETLINECOUNT, 0, ByVal vbNullString)
       
        ' Add a new line to the array of lines
        ReDim Preserve saLines(1 To I) As String
        ' Get the length of the line about to be read, and resize the byte array to make it big enough
        ReDim sLine(0 To SendMessage(hText, EM_LINELENGTH, SendMessage(hText, EM_LINEINDEX, I, ByVal vbNullString) - 1, ByVal vbNullString)) As String
       
        ' Is the line empty?
        If UBound(sLine) >= 1 Then
            ' The line isn't empty
            ' Put length in first word (=2 bytes)
            sLine(0) = UBound(sLine) And &HFF ' LOBYTE(UBound(sLine))
            sLine(1) = UBound(sLine) \ &H100 ' HIBYTE(UBound(sLine))
            ' Get the line
            Call SendMessage(hText, EM_GETLINE, I - 1, sLine(0))
            ' Convert from byte array to string, and put it in the array
            saLines(I) = Left(StrConv(sLine, vbUnicode), UBound(sLine))
        Else
            ' The line is empty
            saLines(I) = vbNullString
        End If
    Next
End Sub

'[end of code]

---

Brief explanation:
The hText parameter is for the hWnd of the TextBox. (If you can get a hWnd of a TextBox belonging to a different program, it will also work!)
The saLines parameter points at a string array which will receive the lines from the TextBox.
Example:

Code:

---

' Copy the contents of a MultiLine TextBox to a ListBox
Private Sub cmdToList_Click()
    Dim saLines() As String, I As Integer
   
    ' Get the lines as they appear:
    Call GetTextBoxLines(txtMyMultiLineTextBox.hWnd, saLines)
   
    ' Clear the ListBox:
    Call lstMyListBox.Clear
   
    ' Copy the lines from the string array to the ListBox:
    For I = 1 To UBound(saLines)
        Call lstMyListBox.AddItem(saLines(I))
    Next
End Sub

---

Enjoy... If you can! :rolleyes:

Code:

---

Public Function FileExists(fName As String) As String
On Local Error Resume Next

        Dim fileName As String
        fileName = FreeFile
        Open fName For Input As fileName
   
            If Err Then
                FileExists = False
            Else
                FileExists = True
            End If

        Close fileName

End Function

---

and clear all textboxes...

Code:

---


Public Sub ClearTextBoxes(theForm As Form)
    Dim Control
    For Each Control In theForm.Controls
        If TypeOf Control Is TextBox Then Control.Text = ""
    Next Control
End Sub

---

I find that relying on errors is a bit contrived

Code:

---

  If Dir$(FileName) <> "" Then
    'file exists
  Else
    'file does not exist
  End If

---

I think the most of you know it, but for the ones who don't:

Code:

---

'[begin of code]
'Author: Hutchie
'Origin: http://www.vb-world.net/tips/tip467.html
'Purpose: Check if there's an active internet connection
'Version: VB5+

Option Explicit

Private Declare Function InternetGetConnectedState _
Lib "wininet.dll" (ByRef lpSFlags As Long, _
ByVal dwReserved As Long) As Long

Private Const INTERNET_CONNECTION_LAN As Long = &H2
Private Const INTERNET_CONNECTION_MODEM As Long = &H1

Public Function Online() As Boolean
    'If you are online it will return True, otherwise False
    Online = InternetGetConnectedState(0&, 0&)
End Function

Public Function ViaLAN() As Boolean

Dim SFlags As Long
'return the flags associated with the connection
Call InternetGetConnectedState(SFlags, 0&)

'True if the Sflags has a LAN connection
ViaLAN = SFlags And INTERNET_CONNECTION_LAN

End Function
Public Function ViaModem() As Boolean

Dim SFlags As Long
'return the flags associated with the connection
Call InternetGetConnectedState(SFlags, 0&)

'True if the Sflags has a modem connection
ViaModem = SFlags And INTERNET_CONNECTION_MODEM

End Function

'[end of code]

---

I thought I'd contribute something myself .

Code:

---

'  Scrambles the order of elements in an array.
'
Public Sub ShuffleArray(ByRef vArray As Variant, Optional startIndex As Variant, Optional endIndex As Variant)
    Dim i As Long
    Dim rndIndex As Long
    Dim Temp As Variant
   
    If IsMissing(startIndex) Then
      startIndex = LBound(vArray)
    End If
   
    If IsMissing(endIndex) Then
      endIndex = UBound(vArray)
    End If

    For i = startIndex To endIndex
        rndIndex = Int((endIndex - startIndex + 1) * Rnd() + startIndex)

        Temp = vArray(i)
        vArray(i) = vArray(rndIndex)
        vArray(rndIndex) = Temp
    Next i
End Sub

---

Here I am with a few other snippets i found recently and think that are of decent use:

Code:

---

'[begin of code]
'Author: Unknown
'Origin: Somewhere on the internet
'Purpose: Show the the current listbox item as tooltip
'Version: VB5+
' --- The ListBoxTooltip class
'
' Usage in the client form:
'
'    Dim lstTT As New ListBoxTooltip
'
'    Private Sub Form_Load()
'        Set lstTT.ListBox = List1
'      End Sub
'    Private Sub Form_Unload(Cancel As Integer)
'        Set lstTT.ListBox = Nothing
'    End Sub

Public WithEvents ListBox As ListBox

Private Sub ListBox_MouseMove(Button As Integer, Shift As Integer, X As Single, _
    Y As Single)
    Dim oldFont As StdFont, itemIndex As Long
   
    ' since a listbox doesn't have a TextHeight method
    ' we must borrow it from its Parent
    With ListBox.Parent
        Set oldFont = .Font
        Set .Font = ListBox.Font
        ' determine which element the mouse is on
        itemIndex = Y \ .TextHeight("A") + ListBox.TopIndex
        ' restore fonts
        Set .Font = oldFont
    End With
   
    ' set the tooltip to the current item's string
    If itemIndex < ListBox.ListCount Then
        ListBox.ToolTipText = ListBox.List(itemIndex)
    Else
        ListBox.ToolTipText = ""
    End If

End Sub

'[end of code]

---

Code:

---


'[begin of code]
'Author: Fred Block
'Origin: http://www.cuzware.com
'Purpose: Shorten a filename with ellipses
'Version: VB6

'        CuzWare Systems
'        E-mail: [email protected]
'        Web Site: http://www.cuzware.com

Function GetShortenedFileName(ByVal strFilePath As String, _
    ByVal maxLength As Long) As String
    Dim astrTemp() As String
    Dim lngCount As Long
    Dim strTemp As String
    Dim index As Long
   
    ' if the path is shorter than the max allowed length, just return it
    If Len(strFilePath) <= maxLength Then
        GetShortenedFileName = strFilePath
    Else
        ' split the path in its constituent dirs
        astrTemp() = Split(strFilePath, "\")
        lngCount = UBound(astrTemp)
       
        ' lets replace each part with ellipsis, until the length is OK
        ' but never substitute drive and file name
        For index = 1 To lngCount - 1
            astrTemp(index) = "..."
            ' rebuild the result
            GetShortenedFileName = Join(astrTemp, "\")
            If Len(GetShortenedFileName) <= maxLength Then Exit For
        Next
    End If
   
End Function

'[end of code]

---

My snippets database is only 10 KB guys, come on, let's go for the 1MB!

I was programming in Revelation (a string based, DB system) when I first ran across the concept of a delimited string.

I'll post one function from a suite, and if anyone is interested, I'll post more.

Public Function sf_Number_of_Elements(Master As String, Marker As String) As Integer
'This function will return the number of elements in Master using Marker as
' the delimiting character.
'
' -1 returned indicates a null Marker
' 0 returned indicates a null Master
' A positive integer indicates the number of elements present. Note that the
' any element (including the final) can be null.

Dim Return_String As Integer, i As Integer, j As Integer

Return_String = -1
If Marker = "" Then GoTo Xit_sf_Number_Of_Elements

Return_String = 0
If Master = "" Then GoTo Xit_sf_Number_Of_Elements

Return_String = 1
i = InStr(Master, Marker)
While i > 0
Return_String = Return_String + 1
i = InStr(i + 1, Master, Marker)
Wend

Xit_sf_Number_Of_Elements:
sf_Number_of_Elements = Return_String
End Function




Good Luck
DerFarm

Here's some really good thing!

Code:

---

'[begin of code]
'Author: Yonatan
'Origin: I wrote it, MSDN helped as always :rolleyes:
'Purpose: Limits size of the form and more. Clean! Subclassing, no Form_Resize()
'Version: VB5+

' ========================================================
' Module code:
' ========================================================

Option Explicit
DefBool B

Type POINTAPI
    X As Long
    Y As Long
End Type

Type MINMAXINFO
    ptReserved As POINTAPI
    ptMaxSize As POINTAPI
    ptMaxPosition As POINTAPI
    ptMinTrackSize As POINTAPI
    ptMaxTrackSize As POINTAPI
End Type

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal cbSrc As Long)

Public Const WM_GETMINMAXINFO = &H24
Public Const GWL_WNDPROC = (-4)

Dim lpPrevWndProc As Long

Public bLimitMaxSize, bLimitMinSize, bUseMaximizedPos, bUseMaximizedSize
Public ptLimitMaxSize As POINTAPI, ptLimitMinSize As POINTAPI
Public ptMaximizedPos As POINTAPI, ptMaximizedSize As POINTAPI

Function GetPOINTAPI(ByVal X As Long, ByVal Y As Long) As POINTAPI
    GetPOINTAPI.X = X
    GetPOINTAPI.Y = Y
End Function

Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim tMinMaxInfo As MINMAXINFO
   
    If uMsg = WM_GETMINMAXINFO Then
        Call CopyMemory(tMinMaxInfo, ByVal lParam, Len(tMinMaxInfo))
       
        If bLimitMaxSize Then tMinMaxInfo.ptMaxTrackSize = ptLimitMaxSize
        If bLimitMinSize Then tMinMaxInfo.ptMinTrackSize = ptLimitMinSize
        If bUseMaximizedPos Then tMinMaxInfo.ptMaxPosition = ptMaximizedPos
        If bUseMaximizedSize Then tMinMaxInfo.ptMaxSize = ptMaximizedSize
       
        Call CopyMemory(ByVal lParam, tMinMaxInfo, Len(tMinMaxInfo))
        Exit Function
    End If
   
    WindowProc = CallWindowProc(lpPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function

Sub SubClass(ByVal hWnd As Long)
    lpPrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Sub UnSubClass(ByVal hWnd As Long)
    Call SetWindowLong(hWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub

' ========================================================
' Form code:
' ========================================================

Option Explicit

Private Sub Form_Load()
    Call SubClass(hWnd)
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Call UnSubClass(hWnd)
End Sub

' ========================================================
' Usage:
' ========================================================

' GetPOINTAPI function: Reducing two lines of code to one.
' Instead of this:
MyPoint.X = SomeXValue
MyPoint.Y = SomeYValue
' Use this:
MyPoint = GetPOINTAPI(SomeXValue, SomeYValue)

' ptLimitMaxSize: This limits the maximum size that the form can reach when resized. It doesn't affect a maximized form.
' Example, to not let anyone resize the form to bigger than 500x500 pixels:
ptLimitMaxSize = GetPOINTAPI(500, 500)
bLimitMaxSize = True ' Activate it

' ptLimitMinSize: This limits the minimum size that the form can reach when resized.
' Example, to not let anyone resize the form to smaller than 100x100 pixels:
ptLimitMinSize = GetPOINTAPI(100, 100)
bLimitMinSize = True ' Activate it

' ptMaximizedPos: This sets the position of the form when you maximize it.
' Example, to make the maximize button put the form in position (50, 50), instead of the default (0, 0):
ptMaximizedPos = GetPOINTAPI(50, 50)
bUseMaximizedPos = True ' Activate it
' Note: This works best when used in conjunction with ptMaximizedSize.

' ptMaximizedSize: This sets the size of the form when it is maximized.
' Example, to make the maximize button resize the form to 400x400, instead of the default fullscreen:
ptMaximizedSize = GetPOINTAPI(400, 400)
bUseMaximizedSize = True ' Activate it

' You can use the Boolean variables to deactivate any of the four options easily.
' Example:
bUseMaximizedPos = True ' Now the form will move to the position in ptMaximizedPos when maximized
bUseMaximizedPos = False ' Now the form will move to the default position (0, 0) when maximized

' You can change the ptWhatever values, and the changes will be applied immediately.
'[end of code]

---

Now, how fun is that? Lots of fun! :rolleyes:

[Edited by Yonatan on 09-27-2000 at 04:20 PM]

Thanks Yoni, that's just what I needed man :)
And DerFarm, I don't use Databases but maybe I will in the future so please guys, keep posting :)

Code:

---

'[Begin of code]
'Author: Escaflowne
'Origin: Written
'Purpose: Imitates keystrokes on Keyboard...or mouse.
'Version: VB5+

Option Explicit

Public Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long

Public Function TypeKeyEx(Keybyte() As Byte) As Boolean
Dim i As Integer, errorex As Long, errorprocess As Boolean
For i = LBound(Keybyte) To UBound(Keybyte)
errorex = SetKeyboardState(Keybyte(i)) 'Sets keyboard State
If errorex = 0 Then errorprocess = False 'Error Processing
If errorex = 0 Then Exit For '------------------^
Next
If errorprocess = True Then TypeKeyEx = True 'Return True if there is no errors
End Function

'[end of code]

---

Usage

Code:

---

    TypeKeyEx([Array of Keystroke Numbers defined as Byte])

---

<Author> Unknown
<source> Web
Jop:

Code:

---

This one will give you hours of pleasure.
Shell:

Use the following snippet to Shell the date/time dialog.
Substitute the codes below for other Control Panel dialogs.
 
 
      Call Shell("rundll32.exe shell32.dll,Control_RunDLL _ timedate.cpl")


 
Couldn't be much easier, could it? The only trick is knowing the "secret code" for each dialog.
Now, while the above will bring up the date/time dialog, your VB app will have no way of knowing when that dialog has been dismissed.
For the answer to that, go to my Samples page and download Shell32.zip which shows several methods you can use to "shell and wait."
So, what are the secret codes? Here ya go...
 
Control Panel (CONTROL.EXE)
 
Control Panel: 
    rundll32.exe shell32.dll,Control_RunDLL
 
 
Accessability Settings (ACCESS.CPL)
 
Accessability Properties (Keyboard): 
    rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1
 
Accessability Properties (Sound): 
    rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2
 
Accessability Properties (Display): 
    rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3
 
Accessability Properties (Mouse): 
    rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4
 
Accessability Properties (General): 
    rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5
 
 
Add/Remove Programs (APPWIZ.CPL)
 
Add/Remove Programs Properties (Install/Uninstall): 
    rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1
 
Add/Remove Programs Properties (Windows Setup): 
    rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,2
 
Add/Remove Programs Properties (Startup Disk): 
    rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,3
 
 
Display Settings (DESK.CPL)
 
Display Properties (Background): 
    rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0
 
Display Properties (Screen Saver): 
    rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1
 
Display Properties (Appearance): 
    rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2
 
Display Properties (Settings): 
    rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3
 

--------------------------------------------------------------------------------
 
Display Properties (Install Screen Saver): 
    rundll32.exe desk.cpl,InstallScreenSaver %1
    (opens .scr at location specified by %1 in preview window)
 
 
FindFast Settings (FINDFAST.CPL)
 
Find Fast Properties (General): 
    rundll32.exe shell32.dll,Control_RunDLL findfast.cpl
 
 
Internet Settings (INETCPL.CPL)
 
Internet Properties (General): 
    rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0
 
Internet Properties (Security): 
    rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,1
 
Internet Properties (Content): 
    rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,2
 
Internet Properties (Connection): 
    rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,3
 
Internet Properties (Programs): 
    rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,4
 
Internet Properties (Advanced): 
    rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,5
 
 
Regional Settings (INTL.CPL)
 
Regional Settings Properties (Regional Settings): 
    rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0
 
Regional Settings Properties (Number): 
    rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,1
 
Regional Settings Properties (Currency): 
    rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,2
 
Regional Settings Properties (Time): 
    rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,3
 
Regional Settings Properties (Date): 
    rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,4
 
Regional Settings Properties (Input Locales): 
    rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,5
 
 
Joystick Settings (JOY.CPL)
 
Joystick Properties (Joystick): 
    rundll32.exe shell32.dll,Control_RunDLL joy.cpl
 
 
Mouse/Keyboard/Printers/Fonts Settings (MAIN.CPL)
 
Mouse Properties: 
    rundll32.exe shell32.dll,Control_RunDLL main.cpl @0
 
Keyboard Properties: 
    rundll32.exe shell32.dll,Control_RunDLL main.cpl @1
 
Printers: 
    rundll32.exe shell32.dll,Control_RunDLL main.cpl @2
 
Fonts: 
    rundll32.exe shell32.dll,Control_RunDLL main.cpl @3
 
 
Mail and Fax Settings (MLCFG32.CPL)
 
Microsoft Exchange/Outlook Properties (General): 
    rundll32.exe shell32.dll,Control_RunDLL mlcfg32.cpl
 
 
Multimedia/Sounds Settings (MMSYS.CPL)
 
Multimedia Properties (Audio): 
    rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0
 
Multimedia Properties (Video): 
    rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,1
 
Multimedia Properties (MIDI): 
    rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,2
 
Multimedia Properties (CD Music): 
    rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,3
 
Multimedia Properties (Advanced/Devices): 
    rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,4
 

--------------------------------------------------------------------------------
 
Sounds Properties: 
    rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1
 
 
Modem Settings (MODEM.CPL)
 
Modem Properties (General): 
    rundll32.exe shell32.dll,Control_RunDLL modem.cpl
 
 
Network Settings (NETCPL.CPL / NCPA.DLL)
 
Network (Configuration): 
    Win9x: rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl
    WinNT: rundll32.exe shell32.dll,Control_RunDLL ncpa.cpl
 

--------------------------------------------------------------------------------
 
Dial-up Networking Wizard
    Win9x: rundll32.exe rnaui.dll,RnaWizard
 

--------------------------------------------------------------------------------
 
Create Share Dialog
    WinNT: rundll32.exe ntlanui.dll,ShareCreate
 
Manage Shares Dialog
    WinNT: rundll32.exe ntlanui.dll,ShareManage
 
 
ODBC Settings (ODBCCP32.CPL)
 
ODBC Data Source Administrator (General): 
    rundll32.exe shell32.dll,Control_RunDLL odbccp32.cpl
 
 
Password Settings (PASSWORD.CPL)
 
Password Properties (Change Passwords): 
    Win9x: rundll32.exe shell32.dll,Control_RunDLL password.cpl
 
 
COM Ports Settings (PORTS.CPL)
 
COM Ports Properties (General): 
    WinNT: rundll32.exe shell32.dll,Control_RunDLL ports.cpl
 
 
Server Properties (SRVMGR.CPL)
 
Server Properties (General): 
    WinNT: rundll32.exe shell32.dll,Control_RunDLL srvmgr.cpl
 
 
System Settings (SYSDM.CPL)
 
System Properties (General): 
    rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0
 
System Properties (Device Manager): 
    Win9x: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,1
 
System Properties (Performance): 
    Win9x: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,3
    WinNT: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,1
 
System Properties (Environment): 
    WinNT: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2
 
System Properties (Startup/Shutdown): 
    WinNT: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,3
 
System Properties (Hardware Profiles): 
    Win95: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2
    WinNT: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,4
 
System Properties (User Profiles): 
    WinNT: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,5
 

--------------------------------------------------------------------------------
 
Add New Hardware Wizard: 
    Win9x: rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1
 
Add New Printer Wizard: 
    Win9x: rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter
 
 
Telephony Settings (TELEPHON.CPL)
 
Dialing Properties (My Location / Drivers): 
    WinNT: rundll32.exe shell32.dll,Control_RunDLL telephon.cpl
 
 
Themes Settings (THEMES.CPL)
 
Themes Properties (General): 
    rundll32.exe shell32.dll,Control_RunDLL themes.cpl
 
 
Time and Date Settings (TIMEDATE.CPL)
 
Date/Time Properties: 
    rundll32.exe shell32.dll,Control_RunDLL timedate.cpl
 
Choose Time Zone: 
    rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,/f
 
 
TweakUI Settings (TWEAKUI.CPL)
 
TweakUI Dialog (General): 
    rundll32.exe shell32.dll,Control_RunDLL tweakui.cpl
 
 
UPS Settings (UPS.CPL)
 
Uninteruptable Power Supply Properties (General): 
    WinNT: rundll32.exe shell32.dll,Control_RunDLL ups.cpl
 
 
Microsoft Mail Postoffice Settings (WGPOCPL.CPL)
 
Microsoft Workgroup Postoffice Admin: 
    rundll32.exe shell32.dll,Control_RunDLL wgpocpl.cpl
 
 
Miscellaneous File System Dialogs and Wizards
 
Open With (File Associations): 
    rundll32.exe shell32.dll,OpenAs_RunDLL d:\path\filename.ext
 
Run Diskcopy Dialog:
    rundll32 diskcopy.dll,DiskCopyRunDll
 
Create New Shortcut Wizard:
    rundll32.exe AppWiz.Cpl,NewLinkHere %1
    (creates shortcut at location specified by %1)
 
Create a Briefcase:
    rundll32.exe syncui.dll,Briefcase_Create
 
View Fonts:
    rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL FontsFolder
 
View Printers:
    rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL PrintersFolder

---

I like this one, it adds all the directories (including subdirectories) into a listbox.

Code:

---

Sub DirMap(ByVal Path As String, List As ListBox)
    On Error Resume Next
    Dim i, j, x As Integer 'All used as counters
    Dim Fname(), CurrentFolder, Temp As String
    Temp = Path
    If Dir(Temp, vbDirectory) = "" Then Exit Sub 'if there arent any sub directories the exit
    CurrentFolder = Dir(Temp, vbDirectory)
    'First get number of folders (Stored in
    '    i)


    Do While CurrentFolder <> ""


        If GetAttr(Temp & CurrentFolder) = vbDirectory Then


            If CurrentFolder <> "." And CurrentFolder <> ".." Then
                i = i + 1
            End If
        End If
        CurrentFolder = Dir
    Loop
    ReDim Fname(i) 'Redim the array With number of folders
    'now store the folder names
    CurrentFolder = Dir(Temp, vbDirectory)


    Do While CurrentFolder <> ""


        If GetAttr(Temp & CurrentFolder) = vbDirectory Then


            If CurrentFolder <> "." And CurrentFolder <> ".." Then
                j = j + 1
                Fname(j) = CurrentFolder
                List.AddItem Temp & Fname(j)
            End If
        End If
        CurrentFolder = Dir
    Loop
    ' For each folder check to see there are


'    sub folders


    For x = 1 To i
        Call DirMap(Temp & Fname(x) & "\", List)
    Next
End Sub

Usage:

Call DirMap("C:\", List1)

---

Happy now Jop? I submitted. More to come...:rolleyes:

Code:

---

'[Begin of code]
'Author: HaxSoft
'Origin: Back of my head.
'Purpose: Filters digits and letters in strings.
'VB version: VB5/VB6

Function IsAlpha(ByVal argText As String) As String

  '*** Dimension local variables...
  Dim strLen  As Long    ' string length
  Dim chrPos  As Long    ' character position
  Dim curChr  As String  ' current character
  Dim chrOkFlg As Boolean  ' character OK flag
  Dim retVal  As String  ' return value

  strLen = Len(argText)    ' get string length


  ' Repeat once for each character in the string.

  For chrPos = 1 To strLen
    curChr = Mid$(argText, chrPos, 1)  ' get current char
    chrOkFlg = False                  ' initialize flag


    ' Is the character a digit?

    If Val(curChr) > 0 Or curChr = "0" Then
      chrOkFlg = True
    Else
      ' Is the current character a letter?

      If UCase$(curChr) <> LCase$(curChr) Then
        chrOkFlg = True
      End If
    End If

    If chrOkFlg = True Then
      retVal = retVal & curChr    ' build return value
    End If
  Next chrPos

  IsAlpha = retVal                ' return value

End Function

'[end of code]

---

The simple ones are always the best, besides which, i love recursion. :D

Code:

---


'[Begin of code]
'Author: Me
'Origin: Answer to Q at VB-World
'Purpose: Creates a directory structure
'VB version: VB5/VB6


Private Sub mkDirStructure(stDir As String)
   
    If Dir$(stDir, vbDirectory) = "" Then
     
      mkDirStructure (Mid$(stDir, 1, InStrRev(stDir, "\") - 1))
      MkDir stDir
    End If
   
End Sub

---

Code:

---

'<Wayne>
'<Necessity..need it for my BDay program>
'<Purpose> Calculate a persons age
'get a persons age if birthday is supplied

Option Explicit

Public Function GetAge(DateString As String) As Integer
      Dim lDate As Date
      lDate = Left$(DateString, 2) + "/" + Mid$(DateString, 3, 2) _
      + "/" + Right$(DateString, 4)
      GetAge = DateDiff("yyyy", lDate, Now)
End Function

Private Sub Command1_Click()
'use your birthday in this format mmddyyyy
    Dim x As String    'this is your birthday var
    x = 12301970      'value
    MsgBox GetAge(x)  'call function
End Sub

---

Here is another great one.

Code:

---

'Author: Iain17
'Origin: Somewhere on the forums
'Purpose: Reverse Replacement
'VB version: VB4/VB5/VB6



Function myRev(stString As String) as String
    Dim i as Integer

    For i = Len(stString) to 1 Step -1
      myRev = myRev & mid$(stString, i, 1)
    next i

End Function

'Usage:

myStr = myRev("Reverse a String")

---

More to come...:rolleyes:

This is a lightning special effect. It can be a snippet, but you're supposed to put it all in a blank form:

Code:

---

'[Begin of code]
'Author: Fox
'Origin: Special Effects for games forum.
'Purpose: Creates a very cool Lightning Effect.
'VB version: VB5/VB6
'API
    Private Declare Function GetTickCount Lib "kernel32" () As Long

'Vars
    Dim Active As Boolean
   
    Dim X2 As Long
    Dim Y2 As Long

Private Sub Form_Load()
    Me.BackColor = 0
    Me.ScaleMode = 3
    Me.Show
    Me.AutoRedraw = True
   
    Active = True
    Draw
End Sub

Public Sub DrawLine(iX As Long, iY As Long, iSize As Long, iColorMul As Long, iMaxAngle As Long, iStartAngle As Long)
    Dim Temp As Single

    Dim NewX As Long
    Dim NewY As Long
   
    Dim Color As Long
    Dim Angle As Long
   
    Dim NewSize As Single
   
    If iSize < 10 Then: Exit Sub
   
    Angle = (iMaxAngle * Rnd)
    Temp = (6.283 / 360 * (iStartAngle + Angle))
   
    NewX = iX + Sin(Temp) * iSize
    NewY = iY + Cos(Temp) * iSize
   
    Color = (iSize * iColorMul)
    If Color > 255 Then: Color = 255
   
    Me.Line (iX, iY)-(NewX, NewY), RGB(Color / 2, Color / 128, Color)
   
    NewSize = (8 * Rnd) / 10 + 1
    DrawLine NewX, NewY, (iSize / NewSize), iColorMul, iMaxAngle / 1.8, iStartAngle + (Angle / 2)
    DrawLine NewX, NewY, (iSize / NewSize), iColorMul, iMaxAngle / 1.8, iStartAngle + (Angle / 2)
End Sub

Public Sub Draw()
    Dim A As Long
    Dim Temp As Long
   
    Dim Text As String
    Dim Angle As Single
    Dim Pos As Single
   
    'I put my(Warmaster199) company's name here
    Text = UCase("COMTECH PRESENTS  ")
    Angle = 6.28 / Len(Text)

    Randomize
    While Active
        If Temp + 100 < GetTickCount Then
            Temp = GetTickCount
           
            Me.Cls
            For A = 0 To 10
                DrawLine X2, Y2, 20 * Rnd + 15, 4 * Rnd + 4, 360, 360 * Rnd
            Next
           
            For A = 1 To Len(Text)
                Me.ForeColor = RGB(128 * Sin(-A * Angle + Pos) + 128, 0, 255 * Sin(-A * Angle + Pos) + 255)
               
                Me.CurrentX = X2 + Sin(Angle * -A + Pos) * 100
                Me.CurrentY = Y2 + Cos(Angle * -A + Pos) * 100
               
                Me.Print Mid(Text, A, 1)
            Next
           
            Pos = Pos + 0.1
        End If
   
        DoEvents
    Wend
End Sub

Private Sub Form_Resize()
    X2 = Me.ScaleWidth / 2
    Y2 = Me.ScaleHeight / 2
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Active = False
End Sub

---

And there you have it. Some awesome effects from Fox, a fellow member of this very forum...

hmmm, i see a pattern emerging here. I seem to like string manipulation, i need help. ;)

Code:

---

'Author: Iain17
'Origin: String Manipulation
'Purpose: InStrRev for VB5
'VB version: VB5/VB6

Function myInStrRev(strStringToSearch As String, strFind As String, Optional iStart As Long) As Long
    Dim ip1 As Long, ip2 As Long
    Dim iLenStringToSearch As Long
    Dim iLenFind As Long
   
    'get the length of the string
    iLenStringToSearch = Len(strStringToSearch)
    iLenFind = Len(strFind)
   
    'if the start is 0 then set the start to the length
    'of the string
    If iStart = 0 Then
      iStart = iLenStringToSearch
    End If
    iStart = iStart + 1
   
    ip1 = 1
    Do
      ip2 = InStr(ip1, strStringToSearch, strFind)
      If (ip2 > 0) And (ip2 + iLenFind <= iStart) Then
        'if ip2 is not zero and it is less than the
        'place to start searching + the length of the
        'find string then set the function
        'to return that position
        myInStrRev = ip2
      ElseIf ip2 = 0 Then
        ip2 = iLenStringToSearch
      End If
      'set the next position to seracf from
      ip1 = ip2 + 1
    Loop Until ip1 >= iStart
   
End Function

---

A fade form code:

Code:

---

'Author: Megatron and Me(fixed and added code from me)
'Origin: Somewhere on the forums
'Purpose: BlackToWhite, WhiteToBlack
'VB version: All VBs

Private Sub BlackToWhite(frm As Form)
    For i = 0 To 255
        DoEvents
        For x = 1 To 50000
        Next x
        frm.BackColor = RGB(i, i, i)
    Next i
End Sub

Private Sub WhiteToBlack(frm As Form)
    For i = 255 To 0 Step -1
        DoEvents
        For x = 1 To 50000
        Next x
        frm.BackColor = RGB(i, i, i)
    Next i
End Sub

'Usage:

'Call BlackToWhite(Me)
'Call WhiteToBlack(Me)

---

More to come...:rolleyes:

Here is a good code to capture the screen and save it to a file.

Code:

---

'Author: Dalin Nie (Edited by Matthew Gates)
'Origin: http://www.vbcode.com
'Purpose: This function capture the screen or the active window of your computer.  Programmatically and save it to a .bmp file.
'VB version: VB 6,VB 5,VB 4/32

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
  ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C


Public Function SaveScreen(ByVal theFile As String) As Boolean
On Error Resume Next

    'To get the Entire Screen
    Call keybd_event(vbKeySnapshot, 1, 0, 0)

    'To get the Active Window
    'Call keybd_event(vbKeySnapshot, 0, 0, 0)

    SavePicture Clipboard.GetData(vbCFBitmap), theFile

SaveScreen = True
Exit Function
End Function

Usage:

Call SaveScreen("C:\Windows\Desktop\ss.bmp")

---

More to come...:rolleyes:

Here is another cool form effect.

Code:

---

'Author: Unknown
'Origin: Unknown
'Purpose: Create Rainbow Text
'VB version: All VBs

Private Sub Form_Paint()
Dim I As Integer, X As Integer, Y As Integer
Dim C As String
Cls
For I = 0 To 91
X = CurrentX
Y = CurrentY
C = Chr(I)
'Line -(X + TextWidth(C), Y = TextHeight(C)), _
QBColor(Rnd * 16), BF
CurrentX = X
CurrentY = Y
ForeColor = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
Print "Hello World Hello World Hello World Hello"
Next
End Sub

---

This next code gives a form a crystalizing effect.

Code:

---

'Author: DmkWare
'Origin: http://www.vbcode.com
'Purpose: Crystalize. This can be turned into a screen saver fast.
Simple yet complicated.
'VB version: VB 6,VB 5,VB 4/32


Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X
As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X
As Long, ByVal Y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Dim bRunning As Boolean 'Running?
Dim iMainX As Integer, iMainY As Integer 'Main Coordinates
Dim iColorOp As Integer 'Render Color Option (1 - 10)
Dim FRMHDC As Long  'Var For Forms DC
Const O_Top = 1    'Hit Bottom Side Come Out Top
Const O_Right = 2  'Hit Left Side Come Out Right
Const O_Bottom = 3  'Hit Bottom Side Come Out Top
Const O_Left = 4    'Hit Right Side Come Out Left
Const Max_Score = 5 'See DoPixelTest
Sub Init()
Randomize 'Initializes the random-number generator
iColorOp = Int(Rnd * 10) 'Choose Random Color Option
bRunning = True 'Running?... uh-huh.
iMainX = Int(Rnd * Form1.ScaleHeight) 'Pick a random X value
iMainY = Int(Rnd * Form1.ScaleWidth)  'Pick a random Y value
Form1.AutoRedraw = True 'Does this need a comment?
Form1.ScaleMode = 3 '3 = Pixel
Form1.BackColor = &H0 'Set Back Color to Black
FRMHDC = GetDC(Form1.hwnd) 'Grab the forms DC
Form1.Show 'Make sure the form shows up...
End Sub
Sub InitOpposite(iOption As Integer)
Select Case iOption
Case O_Top 'Hit Bottom Side Come Out Top
iMainY = 0
Case O_Bottom 'Hit Top Side Come Out Bottom
iMainY = Form1.ScaleHeight - 1
Case O_Left 'Hit Right Side Come Out Left
iMainX = Form1.ScaleWidth - 1
Case O_Right 'Hit Left Side Come Out Right
iMainX = 0
End Select
End Sub
Function FindColor(ColorOption As Integer)
Select Case ColorOption
Case 1
FindColor = RndColor_Red 'See RndColor_Red
Case 2
FindColor = RndColor_Green 'See RndColor_Green
Case 3
FindColor = RndColor_Blue 'See RndColor_Blue
Case 4
FindColor = RndColor_Gray 'See RndColor_Gray
Case 5
FindColor = RndColor_Cyan 'See RndColor_Cyan
Case 6
FindColor = RndColor_Yellow 'See RndColor_Yellow
Case 7
FindColor = RndColor_Fire 'See RndColor_Fire
Case 8
FindColor = RndColor_DrkGreen 'See RndColor_DrkGreen
Case 9
FindColor = RndColor_Ice 'See RndColor_Ice
Case Else 'Everything on the Palette
FindColor = Rnd * &HFFFFFF
End Select
End Function
Function DoPixelTest()
'Test 5 Random Pixels For Color.
'If None are Black, Clear the
'form and Start over...
Static TestScore As Integer, ColorCheck As Long 'Temporary Vars
TestScore = 0
For i = 1 To Max_Score
VBA.Interaction.DoEvents
' \/ Grab Color of Random Pixel \/
ColorCheck = GetPixel(FRMHDC, Int(Rnd * Form1.ScaleWidth), Int(Rnd *
Form1.ScaleHeight))
' \/ If the color isn't black add to the score \/
If Not ColorCheck = &H0 Then TestScore = TestScore + 1
Next
' \/ Report Grade \/
If TestScore = Max_Score Then Form1.Cls: Init
End Function
Function FindNext()
iMainX = RndRange(iMainX - 2, iMainX + 2) 'See RndRange
iMainY = RndRange(iMainY - 2, iMainY + 2)
' \/ Test for Wall Collision \/
If iMainX > Form1.ScaleWidth Then InitOpposite O_Right
If iMainX < 0 Then InitOpposite O_Left
If iMainY > Form1.ScaleHeight Then InitOpposite O_Top
If iMainY < 0 Then InitOpposite O_Bottom
End Function
Sub RenderResults() 'Render
Call SetPixel(FRMHDC, iMainX, iMainY, FindColor(iColorOp))
End Sub
Public Function RndRange(ByVal intMin As Integer, ByVal intMax As Integer)
'This Function Generates a Random number between 2 numbers.
RndRange = Int(Rnd * (intMax - intMin + 1)) + intMin
End Function
Public Function RndColor_Red() 'Random Black to Red
RndColor_Red = Rnd * &HFF
End Function
Public Function RndColor_Green() 'Random Black to Green
RndColor_Green = RGB(0, Int(Rnd * 255), 0)
End Function
Public Function RndColor_DrkGreen() 'Random Black to DarkGreen
RndColor_DrkGreen = RGB(0, Int(Rnd * 150), 0)
End Function
Public Function RndColor_Blue() 'Random Black to Blue
RndColor_Blue = RGB(0, 0, Int(Rnd * 255))
End Function
Public Function RndColor_Gray() 'Random Black to White
Static GShade As Integer
GShade = Int(Rnd * 255)
RndColor_Gray = RGB(GShade, GShade, GShade)
End Function
Public Function RndColor_Fire() 'Random Red & Green
RndColor_Fire = RGB(Int(Rnd * 255), Int(Rnd * 255), 0)
End Function
Public Function RndColor_Yellow() 'Random Black to Yellow
Static GShade As Integer
GShade = Int(Rnd * 255)
RndColor_Yellow = RGB(GShade, GShade, 0)
End Function
Public Function RndColor_Ice() 'Random Green & Blue
RndColor_Ice = RGB(0, Int(Rnd * 255), Int(Rnd * 255))
End Function
Public Function RndColor_Cyan() 'Random Black to Cyan
Static GShade As Integer        'Similar to ICE
GShade = Int(Rnd * 255)
RndColor_Cyan = RGB(0, GShade, GShade)
End Function

Private Sub Form_Load()
Init 'Initialize Everything
Do While bRunning = True 'Loop
VBA.Interaction.DoEvents
FindNext 'See FindNext
RenderResults 'See RenderResults
DoPixelTest 'See DoPixelTest
Loop
End Sub


Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single,
Y As Single)
If Button = 1 Then
Unload Me 'Unload on LeftClick
Else
Form1.Cls: Init 'Restart on RightClick
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
bRunning = False 'End Loop
End              'Terminate Application
End Sub

---

This next code will give you a headache, it is full of all RGB colors.

Code:

---

'Author: Matthew Gates
'Origin: My brain
'Purpose: Headache
'VB version: All VBs
'Comments:  Make sure to set the border property to none and maximize the form.

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

Private Sub WildColors(frm As Form)
Do
frm.BackColor = RGB((Rnd * 255), (Rnd * 255), (Rnd * 255))
DoEvents
Sleep 50
Loop
End Sub

'Usage:


WildColors Me

---

The same effect, but only black and white which will really give you a headache.

Code:

---

'Author: Matthew Gates
'Origin: My brain
'Purpose: Headache (black/white version)
'VB version: All VBs
'Comments:  Make sure to set the border property to none and maximize the form.

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

Private Sub BlackWhite(frm As Form)
Do
frm.BackColor = vbBlack
Sleep 50
frm.BackColor = vbWhite
Sleep 50
DoEvents
Loop
End Sub

'Usage:

BlackWhite Me

---

More to come...:rolleyes:

*wow* guys thank you sooo much :)

I really *love* the Special lightning effects from fox, damn it rules ;)

I just learned how to deal with binairy numbers, so I wrote a function to conver Ascii to Binair, hehe it's dead-easy but in case someone needs it:

Code:

---

'[begin of code]
'Author: Jop
'Origin: ...
'Purpose: Convert Ascii numbers to binair numbers
'Version: VB5+

Private Function MakeBin()
Static bin As String, asc As Long
bin = ""
asc = Val(Text1.Text)
Do
'If 0 Then Exit the loop
If asc = 0 Then Exit Do
'Check if even
If asc Mod 2 = 0 Then
  'If even then add 0 to the binair number
  bin = "0" & bin
  'and divide ascii by 2
  asc = asc / 2
Else
  'If odd then add 1 to the binair number
  bin = "1" & bin
  'Subtract 1 and divide by 2
  asc = (asc - 1) / 2
End If
Loop

MakeBin = bin
End Function

'Usage: Text1.Text = MakeBin
'[end of code]

---

And Matthew, thanks for all your code too :) (I knew you wasn't that greedy LOL :))

This code is really neat, draws a control into a picture box.

Code:

---

'Author: gwdash ?
'Origin: http://forums.vb-world.net/showthrea...threadid=30473
'Purpose: monochrome bitmap from a text box
'VB version: VB4+

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long



Private Sub Command1_Click()
Dim DC As Long
Dim ret As Long
DC = GetWindowDC(Text1.hwnd)
ret = BitBlt(Picture1.hDC, 0, 0, Text1.Width / Screen.TwipsPerPixelX, Text1.Height / Screen.TwipsPerPixelY, DC, 0, 0, vbSrcCopy)
End Sub

---

More to come ? :rolleyes:

Another cool feature that reverses files:

Code:

---

'Author: Unknown
'Origin: ?
'Purpose: Reverse a whole file.
'VB version: VB4+

Public Sub reversefile(fromfile _
As String, tofile As String)
' Fromfile: file to get data from
' Tofile: file to put data in
' Note: This does not work very
' well on strings as it does not seem to
' recognise new lines.

Dim mybyte() As Byte
Dim reversedbyte() As Byte
Dim reversebyte As Long

Open fromfile For Binary As #1
Open tofile For Binary As #2

ReDim mybyte(1 To LOF(1)) As Byte
ReDim reversedbyte(1 To LOF(1)) As Byte
Get #1, , mybyte

For reversebyte = UBound(mybyte) To 1 Step -1
reversedbyte(reversebyte) = mybyte(UBound(mybyte) - _
reversebyte + 1)
Next

Put #2, , reversedbyte

Close #2
Close #1
End Sub


'Usage:

Call reversefile("c:\fromfile.dat","c:\tofile.dat")

---

More to come...:rolleyes: ?

Hi guys, Hi jop...
It was a good idea to do something like this, But why don't we ask the vb-world administer to add a new page or more divided into articles where any vb-word member can post a new snipet in it. I don't think they will refuse our request!!?
If you accept this I hope some body to send them this request (of course not me because my Englis is very bad).