codelib.cod

用VB作的程序电子书

0
BoxGradient
Public Sub BoxGradient(OBJ As Object, R%, G%, B%, RStep%, GStep%, BStep%, Direc As Boolean)
Dim s%, xpos%, ypos%
OBJ.ScaleMode = 3 'pixel
If Direc = True Then
RStep% = -RStep%
GStep% = -GStep%
BStep% = -BStep%
End If
DoBox:
s% = s% + 1
If xpos% < Int(OBJ.ScaleWidth / 2) Then xpos% = s%
If ypos% < Int(OBJ.ScaleHeight / 2) Then ypos% = s%
OBJ.Line (xpos%, ypos%)-(OBJ.ScaleWidth - xpos%, OBJ.ScaleHeight - ypos%), RGB(R%, G%, B%), B
R% = R% - RStep%
If R% < 0 Then R% = 0
If R% > 255 Then R% = 255
G% = G% - GStep%
If G% < 0 Then G% = 0
If G% > 255 Then G% = 255
B% = B% - BStep%
If B% < 0 Then B% = 0
If B% > 255 Then B% = 255
If xpos% = Int(OBJ.ScaleWidth / 2) And ypos% = Int(OBJ.ScaleHeight / 2) Then Exit Sub
GoTo DoBox
End Sub
鼢鼢鼢
BoxGradient

Fills the form or picturebox with a gradient in a box.

Syntax:  BoxGradient(Object, R%, G%, B%, RStep%, GStep%, BStep%, Direc As Boolean)

Object: Form or PictureBox (must support the line-method)
R: Red component of the starting color
G: Green component of the starting color
B: Blue component of the starting color
RStep: The value substracted from the Red-component
GStep: The value substracted from the Green-component
BStep: The value substracted from the Blue-component
Direc: True or False
              True: Gives the steps a negative value
              False: Gives the steps a positive value

Examples:

Call BoxGradient(Form1, 64, 128, 240, 5, 3, 2, True)
Call BoxGradient(Picture1, 240, 128, 64, 2, 3, 4, False)
鼢鼢鼢
AutoRedraw of the Form/PictureBox must be set to True

Coded by Stephan Swervaegher
鼢鼢鼢
 3 
Euro
Public Function Euro(EuroFix As Variant, Amount As Variant) As Variant
Euro = Format(Amount / EuroFix, "#0.00")
End Function
鼢鼢鼢
This function calculates the amount of
Euro for a given amount of money

Example (for Belgium):

Dim A%

A = Euro(40.3399,1000)

40.3399 is the fix
1000 = 1000 Bfr

A will be 24.79 Euro


鼢鼢鼢
Only for certain countries in Europe.

Code provided by Stephan Swertvaegher
鼢鼢鼢
0
ColBar
Public Sub ColBar(Obj As Object, St%, H%, R%, G%, B%, RE%, GE%, BE%)
Dim H2%, H3%, IvR%, IvG%, IvB%
Obj.AutoRedraw = True
Obj.ScaleMode = 3 'pixel
H3 = Int(H / 2)
IvR = Int(RE - R) / H3
IvG = Int(GE - G) / H3
IvB = Int(BE - B) / H3
Do While H >= H3
Obj.Line (0, St + H2)-(Obj.ScaleWidth, St + H2), RGB(R, G, B)
Obj.Line (0, St + H)-(Obj.ScaleWidth, St + H), RGB(R, G, B)
H = H - 1
H2 = H2 + 1
R = R + IvR
G = G + IvG
B = B + IvB
Loop
End Sub
鼢鼢鼢
Colbar

Puts a gradient bar on the screen.

Syntax: Call ColBar(Object, St, H, R, G, B, RE, GE, BE)

Object: Form or PictureBox (must support the line-method)
St: Start in pixels of the ColBar
H: Height of the ColBar
R: Red component of the starting color
G: Green component of the starting color
B: Blue component of the starting color
RE: Red component of the ending color
GE: Green component of the ending color
BE: Blue component of the ending color

Note:
* The Object must be in ScaleMode = 3 (Pixels) and AutoRedraw = true
* By setting the starting values of R, G, and B bigger than the
  ending values, you create a negative ColBar.
* The values of R, G, and B must not exceed 255.

Examples:

Call ColBar(Form1, 0, 50, 64, 0, 64, 255, 5, 200)
Call ColBar(Form1, 200, 60, 255, 184, 255, 55, 55, 140) 'negative colorbar!

鼢鼢鼢
Coded by Stephan Swervaegher
鼢鼢鼢
 4 
EqualColor
Private Function EqColors(Obj As Form)
For Each Control In Obj.Controls
On Error Resume Next
    Control.BackColor = Obj.BackColor
Next Control
End Function
鼢鼢鼢
Equals all backcolors of the controls to the
backcolor of the form.
An error handler is build in, so if this function meets a control with no
backcolor-property, this control will be skipped.

Example:

EqColors Form1


This will equal all controls in Form1
鼢鼢鼢
This function can also be done like this:

Private Function EqColors(Obj As Form, EqColR%, EqColG%, EqColB%)
For Each Control In Obj.Controls
On Error Resume Next
    Control.BackColor = RGB(EqColR, EqColG, EqColB)
Next Control
End Function

Here you give the R, G and B-values to the function.
All controls on the form will have the same color, specified by R,G and B

Example:

EqColors Form1, 128,64,192
鼢鼢鼢
1
FileExists
Private Function FileExists(QVBestand$) As Boolean
    FileExists = (Dir(QVBestand) <> "")
End Function
鼢鼢鼢
FileExists

Syntax: FileExists (Path)

Returns True if File exists
Returns False if file doesn't exist

Example:

Dim Temp as Boolean
Temp = FileExists(C:\MyPath\Picture.jpg)
If Temp = False then Exit Sub
MsgBox("This File exists !") 'Temp = True

鼢鼢鼢
鼢鼢鼢
0
3D-Text
Public Sub Rel3D(Obj As Object, Txt$, CX%, CY%, Sh As Long, Fc As Long)
Dim KL%
Obj.ForeColor = Sh
For KL = 1 To 3
Obj.CurrentX = CX + KL
Obj.CurrentY = CY + KL
Obj.Print Txt
Next KL
Obj.ForeColor = Fc
Obj.CurrentX = CX
Obj.CurrentY = CY
Obj.Print Txt
End Sub
鼢鼢鼢
3D-Text

Prints text with a shadow

Syntax: Rel3D(Object, Txt, CX, CY, Sh, Fc)

Object: Form or PictureBox
Txt: The string to be printed
CX CY: X and Y-coordinates (= CurrentX and CurrentY)
Sh: The color of the shadow (as long)
Fc: The ForeColor of the printed text (as long)

Example:

Call Rel3D(Form1, "This is a test", 100, 50, &H0, &HFF0000)

鼢鼢鼢
Coded by Stephan Swervaegher
鼢鼢鼢
 3 
HexToRGB
Private Function HexToRGB(H As String) As Currency
' Converts Hexidecimal to RGB

On Error GoTo error
Dim Tmp$
Dim lo1 As Integer, lo2 As Integer
Dim hi1 As Long, hi2 As Long
Const Hx = "&H"
Const BigShift = 65536
Const LilShift = 256, Two = 2
Tmp = H
If UCase(Left$(H, 2)) = "&H" Then Tmp = Mid$(H, 3)
Tmp = Right$("0000000" & Tmp, 8)
If IsNumeric(Hx & Tmp) Then
lo1 = CInt(Hx & Right$(Tmp, Two))
hi1 = CLng(Hx & Mid$(Tmp, 5, Two))
lo2 = CInt(Hx & Mid$(Tmp, 3, Two))
hi2 = CLng(Hx & Left$(Tmp, Two))
HexToRGB = CCur(hi2 * LilShift + lo2) * BigShift + (hi1 * LilShift) + lo1
End If
Exit Function
error:  MsgBox Err.Description, vbExclamation, "Error"
End Function
鼢鼢鼢
鼢鼢鼢
Code from Planet Source

Not sure if this works properly...
鼢鼢鼢
2
SoundPlay
Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Const snd_sync = &H0
Public Const snd_async = &H1
Public Const snd_loop = &H8
Public Const snd_Alias = &H10000
Public Const snd_filename = &H20000 
Public Const snd_loop = &H8 
Public Const snd_nodefault = &H2 
Public Const snd_nostop = &H10 
Public Const snd_nowait = &H2000 


鼢鼢鼢
sndPlaySound

Zero or more of the following flags specifying how to play the sound: 
SND_ALIAS = &H10000 'Play a Windows sound (such as SystemStart, Asterisk, etc.). 
SND_ASYNC = &H1 'Continue program execution immediately after starting to play the sound. 
SND_FILENAME = &H20000 'Play the specified filename. 
SND_LOOP = &H8 'Play the sound repeatedly until sndPlaySound is called again with lpszSoundName = "". SND_ASYNC must also be set. 
SND_NODEFAULT = &H2 'Do not play the Windows default sound if the specified sound cannot be found. 
SND_NOSTOP = &H10 'Do not stop playing any currently playing sounds. 
SND_NOWAIT = &H2000 'Do not wait if the sound driver is busy. 
SND_SYNC = &H0 'Wait until the sound has finished playing before continuing program execution. 

Example:

Private Sub Command1_Click()
WaveName = "C:\WavFiles\Horn.wav"
Call PLAY
End Sub

'in a module
Public RC
Public WavName As String 'A folder, containing a .WAV-file

Sub PLAY(sndnr As Integer, snd As Integer)
RC = sndPlaySound(WavName, 1)
End Sub
鼢鼢鼢
鼢鼢鼢
 3 
CalculateRoot
Private Function CalcRoot(power As Variant, numb As Variant) As Variant
CalcRoot = numb ^ (1 / power)
End Function
鼢鼢鼢
CalcRoot Function

Calculates the n-root

Syntax: CalcRoot(power, number)

Returns: The calculation as a variant

Example:

Dim A as Variant
A = CalcRoot(5, 9765625)

' A will contain 25
鼢鼢鼢
Coded by Stephan Swertvaegher
鼢鼢鼢
 5 
HoldChr
Public Function HoldChar(Char%, HoldString) As Integer
Dim Hc%
For Hc = 1 To Len(HoldString)
If Char = Asc(Mid(HoldString, Hc, 1)) Then
HoldChar = 0
Exit For
Else
HoldChar = Char
End If
Next Hc
End Function
鼢鼢鼢
HoldChr

Makes sure certain characters cannot be typed.

Syntax: HoldChr(Char, HoldString)

Char: The Ascii-value
HoldString: A String that contains all of the characters that cannot be typed

Remarks:
* The HoldChr must be called from KeyPress-Event of a textbox

Example:

Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = HoldChar(KeyAscii, "acegikm")
'does not type a, c, e, g, i, k, m
End Sub

鼢鼢鼢
鼢鼢鼢
 3 
HexColor
Private Function HexColor(Red%, Green%, Blue%) As String
'returns the RGB colors as a Hexadecimal string
HexColor = Hex(Blue)
HexColor = HexColor + Hex(Green)
HexColor = HexColor + Hex(Red)
End Function
鼢鼢鼢
鼢鼢鼢
Code provided by Stephan Swertvaegher
鼢鼢鼢
0
Border
Public Sub ColForm(Obj As Object, R%, G%, B%, Step%)
Dim R1%, G1%, B1%, R2%, G2%, B2%
Obj.ScaleMode = 3 'pixels
Obj.AutoRedraw = True 'very important !
Obj.BackColor = RGB(R%, G%, B%)
R1% = R% + Step%: If R1% > 255 Then R1% = 255
G1% = G% + Step%: If G1% > 255 Then G1% = 255
B1% = B% + Step%: If B1% > 255 Then B1% = 255
R2% = R% - Step%: If R2% < 0 Then R2% = 0
G2% = G% - Step%: If G2% < 0 Then G2% = 0
B2% = B% - Step%: If B2% < 0 Then B2% = 0
Obj.Line (2, 2)-(Obj.ScaleWidth - 2, Obj.ScaleHeight - 2), RGB(R1%, G1%, B1%), B
Obj.Line (Obj.ScaleWidth - 2, 2)-(Obj.ScaleWidth - 2, Obj.ScaleHeight - 1), RGB(R2%, G2%, B2%)
Obj.Line (1, Obj.ScaleHeight - 2)-(Obj.ScaleWidth - 2, Obj.ScaleHeight - 2), RGB(R2%, G2%, B2%)
Obj.Line (5, 5)-(Obj.ScaleWidth - 5, Obj.ScaleHeight - 5), RGB(R2%, G2%, B2%), B
Obj.Line (Obj.ScaleWidth - 5, 6)-(Obj.ScaleWidth - 5, Obj.ScaleHeight - 4), RGB(R1%, G1%, B1%)
Obj.Line (5, Obj.ScaleHeight - 5)-(Obj.ScaleWidth - 5, Obj.ScaleHeight - 5), RGB(R1%, G1%, B1%)
End Sub
鼢鼢鼢
ColForm

Puts a 3D-border arround the screen.

Syntax: Call ColForm(Obj As Object, R%, G%, B%, Step%)

Object: Form or PictureBox (must support the line-method)
R: Red component of the form-color
G: Green component of the form-color
B: Blue component of the form-color
Step: The step to lighten and darken the border

Note:
* The Object must be in ScaleMode = 3 (Pixels) and AutoRedraw = true
* The values of R, G, and B must not exceed 255.

Examples:

Call ColForm(Form1, 192, 192, 192, 75)
Call ColForm(Form1, 40, 192, 128, 35)

鼢鼢鼢
Coded by Stephan Swervaegher

The best effect is with a form-borderstyle of 0 (no border).
鼢鼢鼢
0
Gradient
Public Sub Gradient(Obj As Object, R1 As Single, G1 As Single, B1 As Single, R2 As Single, G2 As Single, B2 As Single, Angle as Boolean)
Dim R, G, B As Single
Dim Wi%
Obj.AutoRedraw = True
Obj.ScaleMode = 3
If Angle = False Then
R = (R2 - R1) / Obj.ScaleHeight
G = (G2 - G1) / Obj.ScaleHeight
B = (B2 - B1) / Obj.ScaleHeight
For Wi = 0 To Obj.ScaleHeight - 1
Obj.Line (0, Wi)-(Obj.ScaleWidth - 1, Wi), RGB(R1, G1, B1)
R1 = R1 + R
G1 = G1 + G
B1 = B1 + B
Next Wi
Exit Sub
End If
If Angle = True Then
R = (R2 - R1) / Obj.ScaleWidth
G = (G2 - G1) / Obj.ScaleWidth
B = (B2 - B1) / Obj.ScaleWidth
For Wi = 0 To Obj.ScaleWidth - 1
Obj.Line (Wi, 0)-(Wi, Obj.ScaleHeight - 1), RGB(R1, G1, B1)
R1 = R1 + R
G1 = G1 + G
B1 = B1 + B
Next Wi
Exit Sub
End If
End Sub
鼢鼢鼢
Gradient

Makes the Form (or PictureBox) gradient

Syntax: Call Gradient(Object, R1, G1, B1, R2, G2, B2, Angle)

Object: Form or PictureBox (must support the line-method)
R1: Red component of the starting color
G1: Green component of the starting color
B1: Blue component of the starting color
R2: Red component of the ending color
G2: Green component of the ending color
B2: Blue component of the ending color
Angle: True or False
                 True: Gradient from left to right
                 False: Gradient from top to bottom

Note:
* The Object must be in ScaleMode = 3 (Pixels) and AutoRedraw = true
* By setting the starting values of R, G, and B bigger than the
  ending values, you create a negative ColBar.
* The values of R, G, and B must not exceed 255.
* For better calculations the values Of R1...B2 are Single.

Examples: