codelib.cod

用VB作的程序电子书

Me.Move (Screen.Width / 2) - (Me.Width / 2), (Screen.Height / 2) - (Me.Height / 2)
'Next, call the ExplodeForm
ExplodeForm Form1, 200, vbRed
End Sub

鼢鼢鼢
Code from Planet Source

鼢鼢鼢
 2 
CountLinesInTextbox2
Private Declare Function SendMessageAsLong Lib "user32"  Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Function GetLineCount(C as Control)
  Const EM_GETLINECOUNT = 186
  GetLineCount = SendMessageAsLong(C.Hwnd, EM_GETLINECOUNT, 0, 0)
End Function
鼢鼢鼢
CountLinesInTextBox

Counts the lines in a Multiline TextBox

Syntax: GetLineCount(C)

C: TextBox

Example:

Private Sub Text1_Change()
Label1.Caption = GetLineCount(Text1)
End Sub

鼢鼢鼢
鼢鼢鼢
 4 
SetLine
Public Function Setline(OBJ As Object, LineY%, Optional LineStyle as Boolean)
If IsMissing(LineStyle) then LineStyle = False
If LineStyle = False Then
OBJ.Line (0, LineY)-(OBJ.ScaleWidth, LineY), RGB(128, 128, 128)
OBJ.Line (0, LineY + 1)-(OBJ.ScaleWidth, LineY + 1), RGB(240, 240, 240)
Else
OBJ.Line (0, LineY)-(OBJ.ScaleWidth, LineY), RGB(240, 240, 240)
OBJ.Line (0, LineY + 1)-(OBJ.ScaleWidth, LineY + 1), RGB(128, 128, 128)
End If
End Function

鼢鼢鼢
SetLine

Sets a 3D line on the screen

Syntax: Setline Object, Y, [LineStyle]

Object: Form or PictureBox
Y: The y-coordinate of the line to appear
LineStyle: (Optional) True or False
   True: Sets the line raised (default)
   False: Sets the line inset

Remarks:
* The objects Scale-property must be set to 3 (pixel) and AutoRedraw = True
* The LineStyle is False by default (inset)
* Best effect with standard forms - with a grey background
 
Examples

SetLine Form1, 20 'sets a line on Form1, on Y-position = 20, inset
SetLine Form2, 55, 1  'sets a line on Form2, on Y-position = 55, raisedt
SetLine Picture1, 10, 0  'sets a line on Picture1, on Y-position = 10, inset
鼢鼢鼢
鼢鼢鼢
 5 
NumChr
Public Function NumChr(Char%)
If Char = 13 Or Char = 8 Then NumChr = Char: Exit Function 'detect enter & backspace
If Char < 42 Or Char > 57 Then Char = 0
NumChr = Char
End Function
鼢鼢鼢
NumChr

Will type only the characters: * + , - . / 0 1 2 3 4 5 6 7 8 9
This function must be called from the KeyPress-event
This is usefull for textboxes where only numbers may be typed.

Remark:

The enter-code (13) and backspace-code (8) still works

Example:

Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = NulChr(KeyAscii)
End Sub


鼢鼢鼢
鼢鼢鼢
 5 
UAscii
Private Function UAscii(Key%) As Integer
If Key > 96 And Key < 133 Then Key = Key - 32
UAscii = Key
End Function

鼢鼢鼢
UAscii Function

All characters are typed in upper-case
When you type: abcde or AbCDe, the textbox displays always ABCDE

Example:

Private Sub Text1_KeyPress(KeyAscii As Integer)
Keyascii = UAscii(KeyAscii)
End Sub

鼢鼢鼢
鼢鼢鼢
 4 
Grad
Public Enum DirecGrad
Horiz
Vertic
End Enum

Public Function Grad(Obj As Object, Col1 As Long, Col2 As Long, Optional Dgrad As DirecGrad)
Dim R1, R2, G1, G2, B1, B2, Sr, Sg, Sb, H%, H2%, xxx%
Dim R, G, B
Dim TmpScale%
On Error Resume Next
If IsMissing(Dgrad) Then Dgrad = Horiz
TmpScale = Obj.ScaleMode
Obj.ScaleMode = 3
Obj.AutoRedraw = True
R1 = Col1 And &H800000FF
R2 = Col2 And &H800000FF
G1 = (Col1 And &H8000FF00) / &H100
G2 = (Col2 And &H8000FF00) / &H100
B1 = (Col1 And &H80FF0000) / &H10000
B2 = (Col2 And &H80FF0000) / &H10000
If Dgrad = Horiz Then
H = Obj.ScaleHeight
Else
H = Obj.ScaleWidth
End If
Sr = (R2 - R1) / H
Sg = (G2 - G1) / H
Sb = (B2 - B1) / H
For xxx = 0 To H
If Dgrad = Horiz Then
Obj.Line (0, xxx)-(Obj.ScaleWidth, xxx), RGB(R1, G1, B1)
Else
Obj.Line (xxx, 0)-(xxx, Obj.ScaleHeight), RGB(R1, G1, B1)
End If
R1 = R1 + Sr
G1 = G1 + Sg
B1 = B1 + Sb
Next xxx
Obj.ScaleMode = TmpScale
End Function
鼢鼢鼢
Grad Function

Gradient a form or picturebox with two colors

Syntax:  Grad Object, Col1, Col2, [Dgrad]

Object: Form or PictureBox
Col1: First color of the gradient - long value
Col2: Second color of the gradient - long value
Dgrad: Optional
        Horiz: Horizontal gradient
        Vertic: Vertical gradient

Remarks:
If Dgrad is omitted then the horizontal gradient will be executed

Examples:

Grad Form1, &HFF0080, &H8040&
Grad Form1, &H40A0E0, &H8040FF, Vertic
Grad Picture1, &H804080, &HFF&, Horiz

鼢鼢鼢
鼢鼢鼢
 4 
Grad3
Public Enum DirecGrad
Horiz
Vertic
End Enum

Public Function Grad3(Obj As Object, Col1 As Long, Col2 As Long, Col3 As Long, Optional Dgrad As DirecGrad)
Dim R1, R2, R3, G1, G2, G3, B1, B2, B3, Sr, Sg, Sb, H%, H2%, xxx%
Dim R, G, B
Dim TmpScale%
On Error Resume Next
If IsMissing(Dgrad) Then Dgrad = Horiz
TmpScale = Obj.ScaleMode
Obj.ScaleMode = 3
Obj.AutoRedraw = True
R1 = Col1 And &H800000FF
R2 = Col2 And &H800000FF
R3 = Col3 And &H800000FF
G1 = (Col1 And &H8000FF00) / &H100
G2 = (Col2 And &H8000FF00) / &H100
G3 = (Col3 And &H8000FF00) / &H100
B1 = (Col1 And &H80FF0000) / &H10000
B2 = (Col2 And &H80FF0000) / &H10000
B3 = (Col3 And &H80FF0000) / &H10000
    If Dgrad = Horiz Then
    H = Obj.ScaleHeight / 2
    H2 = Obj.ScaleHeight
    Else
    H = Obj.ScaleWidth / 2
    H2 = Obj.ScaleWidth
    End If
    
    Sr = (R2 - R1) / H
    Sg = (G2 - G1) / H
    Sb = (B2 - B1) / H
    For xxx = 0 To H
    If Dgrad = Horiz Then
    Obj.Line (0, xxx)-(Obj.ScaleWidth, xxx), RGB(R1, G1, B1)
    Else
    Obj.Line (xxx, 0)-(xxx, Obj.ScaleHeight), RGB(R1, G1, B1)
    End If
    R1 = R1 + Sr
    G1 = G1 + Sg
    B1 = B1 + Sb
    Next xxx
    Sr = (R3 - R2) / H
    Sg = (G3 - G2) / H
    Sb = (B3 - B2) / H
    For xxx = H To H2
    If Dgrad = Horiz Then
    Obj.Line (0, xxx)-(Obj.ScaleWidth, xxx), RGB(R2, G2, B2)
    Else
    Obj.Line (xxx, 0)-(xxx, Obj.ScaleHeight), RGB(R2, G2, B2)
    End If
    R2 = R2 + Sr
    G2 = G2 + Sg
    B2 = B2 + Sb
    Next xxx
Obj.ScaleMode = TmpScale
End Function
鼢鼢鼢
Grad3 Function

Gradient a form or picturebox with three colors

Syntax:  Grad Object, Col1, Col2, Col3, [Dgrad]

Object: Form or PictureBox
Col1: First color of the gradient - long value
Col2: Second color of the gradient - long value
Col3: Third color of the gradient - long value
Dgrad: Optional
        Horiz: Horizontal gradient
        Vertic: Vertical gradient

Remarks:
If Dgrad is omitted then the horizontal gradient will be executed

Examples:

Grad Form1, &HFF0080, &h0, &H8040&
Grad Form1, &H40A0E0, &H8040FF,&hFFFFFF,  Vertic
Grad Picture1, &H804080, &HFF&, &fA080C0, Horiz

鼢鼢鼢
鼢鼢鼢
 6 
CryptText
Public Function CryptText(CrTxt$, CrCode)
Dim CrX%
CrCode = CrCode and &HFF& ' max 255 !
For CrX = 1 To Len(CrTxt)
If Mid(CrTxt, CrX, 1) <> Chr(13) Then
Mid(CrTxt, CrX, 1) = Chr(Asc(Mid(CrTxt, CrX, 1)) Xor CrCode)
End If
Next CrX
CryptText = CrTxt
End Function

鼢鼢鼢
CryptText Function

Syntax: CryptText(CrTxt, CrCode)

CrTxt: The text to be crypted
CrCode: The cryption-code. This must be in the range of 1 - 255.

Remarks:
* This is an easy way to crypt a text.
* To uncrypt, call the same function again (with the same cryption-code !!!)
* A CrCode of 0 cannot be used, because the text will not be changed.

Examples:

A = CryptText("This is an example, 1)
Label1.caption = CryptText("This is another example, 155)

A full example:
' Start a new project and add a Command-button and a Label
' Put the CryptText-function in a module
' Press the command button to crypt the text
' Press the command button again to decrypt the text

Private Sub Form_Load()
Label1.Caption = "This is a test" & vbCr & "to see what happens"
End Sub

Private Sub Command1_Click()
Label1.Caption = CryptText(Label1.Caption, 1)
End Sub

鼢鼢鼢
鼢鼢鼢
 6 
BackText
Public Function BackText(BkTxt$)
If BkTxt = "" Then BackText = "": Exit Function
Dim Bkx%, NewBkTxt$
For Bkx = Len(BkTxt) To 1 Step -1
NewBkTxt = NewBkTxt & Mid(BkTxt, Bkx, 1)
Next Bkx
BackText = NewBkTxt
End Function

鼢鼢鼢
BackText Function

Reverses a given string

Syntax: BackText(BkTxt)

BkTxt: The string to reverse

Example:

Label1.Caption =BackText(Label1.Caption)

Dim A$, B$
A = "This is a test"
B$ = BackText(A)

鼢鼢鼢
鼢鼢鼢
 6 
AnaGram
Public Function AnaGram(AnaWord$) As String
if AnaWord = "" then AnaGram = "": Exit Function
Dim QQ%, An%, An1%
ReDim An2%(Len(AnaWord))
AnaGram = ""
For An = 1 To Len(AnaWord)
NewRnd:
Randomize
An1 = Int(Rnd * Len(AnaWord)) + 1
    For QQ = 1 To An
    If An2(QQ) = An1 Then GoTo NewRnd
    Next QQ
An2(An) = An1
Anagram = Anagram + Mid(AnaWord, An1, 1)
Next An
End Function
鼢鼢鼢
AnaGram

This function returns an anagram of a given string.

Syntax:  AnaGram(AnaWord)

AnaWord: A string to be scrambled

Example:

Label1.Caption = AnaGram(Label1.Caption)

Dim A$, B$
A = "This is a test"
B$ = AnaGram(A)

鼢鼢鼢
鼢鼢鼢
 2 
OpenURL
#If Win32 Then
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
Private Declare Function ShellExecute Lib "shell.dll" (ByVal hwnd As Integer, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Integer) As Integer
#End If
Private Const SW_SHOWNORMAL = 1

Private Sub Command1_Click()
Dim iret As Long
    iret = ShellExecute(Me.hwnd, vbNullString, "http://www.whateversite.com", vbNullString, "c:\", SW_SHOWNORMAL)
End Sub

Private Sub Command2_Click()
Dim iret As Long
    iret = ShellExecute(Me.hwnd, vbNullString, "mailto:[e-mail]", vbNullString, "c:\", SW_SHOWNORMAL)
End Sub

鼢鼢鼢
OpenURL Api

Syntax:
' for win32
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Opens the default webbrowser or email-program from within VB

Examples:

Private Sub Command1_Click() 'Open web-browser
Dim iret As Long
' replace the adress by the adres you want.
    iret = ShellExecute(Me.hwnd, vbNullString, "http://www.asitetovisit.com", vbNullString, "c:\", SW_SHOWNORMAL)
End Sub

Private Sub Command2_Click() 'Open e-mail program
Dim iret As Long
' replace the adress by the adress you want
    iret = ShellExecute(Me.hwnd, vbNullString, "mailto:[e-mail]", vbNullString, "c:\", SW_SHOWNORMAL)
End Sub

鼢鼢鼢
鼢鼢鼢
 4 
Grad45
Public Enum GradDir
LeftRight
RightLeft
End Enum
Public Function Grad45(Obj As Object, RG1, GG1, BG1, Optional RG2, Optional GG2, Optional BG2, Optional GrDir As GradDir)
If IsMissing(RG2) Then RG2 = 0
If IsMissing(GG2) Then GG2 = 0
If IsMissing(BG2) Then BG2 = 0
If IsMissing(GrDir) Then GrDir = LeftRight
Dim RGS, GGS, BGS, ScG%, NewL%, NewR, NewG, NewB, Gx%
ScG = Obj.ScaleMode
Obj.ScaleMode = 3 'pixel
Obj.AutoRedraw = True
Obj.DrawWidth = 2
Obj.DrawStyle = 6
'-----------
NewL = Obj.ScaleWidth + Obj.ScaleHeight
RGS = (RG2 - RG1) / NewL
GGS = (GG2 - GG1) / NewL
BGS = (BG2 - BG1) / NewL
For Gx = 0 To NewL
If GrDir = LeftRight Then
Obj.Line (0, Gx)-(Gx, 0), RGB(Int(RG1), Int(GG1), Int(BG1))
Else
Obj.Line (Obj.ScaleWidth - NewL + Gx, 0)-(Obj.ScaleWidth, NewL - Gx), RGB(Int(RG1), Int(GG1), Int(BG1))
End If
RG1 = (RG1 + RGS)
GG1 = (GG1 + GGS)
BG1 = (BG1 + BGS)

Next Gx

Obj.ScaleMode = ScG
End Function

鼢鼢鼢
Grad45 Function

Does gradient the form or picturebox with 45