BEAL MANOR

Visual Basic Code

Back to Beal Manor HomePage

This Web Site is for sharing Short Visual Basic Routines. I am looking for really useful subroutines that everyone can use. I have including some routines that I have written, but I will post any routines sent to me that look interesting. Please do not send me routines taken from books or magazines without the author's permission. I am looking for code that exists in the public domain. If code published here can be written better, as often it can, please send me your recommendations and I will post them. This is also a code only area, please do not send me any form dependent subroutines.

Lonny Beal's Routines - To save space in posting, I have used the automatic variant declaration for all variables.

Function fnHR(x) 'I find it useful to turn time from the form of HH.MM into HH.HH for math 
       fnHR = ((x - Fix(x)) * 1.66666666) + Fix(x)
End Function

Function fnHMS(z) 'After the math, I return time back from HH.HH to HH.MM
	fnHMS = ((z - Fix(z)) * 0.6) + Fix(z)
End Function

Function fnRad(z) 'To convert from Degrees to Radians
	fnRad = z / 57.295779513
End Function

Function fnDeg(z) 'To convert from Radians to Degrees
	fnDeg = z * 57.295779513
End Function

Function fnCS(X2) 'The VB functions of COS and SIN need the Radian 
				'equivalents of degrees
	fnCS = Cos(fnRad(X2)) 'Here shows an example of a routine that 
				'will allow degrees to be give you
End Function 'a COS

Function fnACOS(Y) 'Since, there is no ARCCOS, here is one (using degrees)
	fnACOS = fnDeg(3.1415927 / 2 - (fnRad(fnASIN(Y))))
End Function

Function fnASIN(x) 'Here is the same for ARCSIN (ARCTAN is available)
	fnASIN = fnAT(x / ((1 - x ^ 2) ^ 0.5)) 'fnAT is a function like fnCS for ArcTan
End Function

Private Sub Shuffle_Deck() 'This routine shuffles a global integer array DECK(52,2)
	message.Caption = "Deck Shuffled" 'representing a deck of cards.
	For x = 1 To 13
		For y = 1 To 4
			Cards(x, y) = 0 'The global integer array CARDS(13,4) is to insure
		Next y 'no duplicates are placed in the deck
	Next x
	For x = 1 To 52
ChooseCard:
		a = Int(Rnd(1) * 13# + 1#)
		b = Int(Rnd(1) * 4# + 1#)
		If Cards(a, b) = 0 Then
			Cards(a, b) = 1
			Deck(x, 1) = a
			Deck(x, 2) = b
		Else GoTo ChooseCard
		End If
	Next x
	Counter = 1 'The global integer variable Counter is set to 1 to mark
End Sub		'the available card to be pulled from the deck

Private Sub Get_Card() 'Here is the corresponding Get Card routine for the above
	Value = Deck(Counter, 1) 'shuffled deck
	Suit = Deck(Counter, 2) - 1 'Value, Suit and Counter are Global variables. This can be
	Counter = Counter + 1 'redone with local variables for Value and Suit
End Sub

Public Sub CenterForm(frm As Form) 'Here is a handy routine that centers the form on the screen
	frm.Left = (Screen.Width - frm.Width) / 2 'You can send it the CenterForm Me command to center
	frm.Top = (Screen.Height - frm.Height) / 2 'the active form.
End Sub

' Foyal Carter submitted this improvement to the above routine.

Private Sub CenterForm(F as Form)
	F.Move (Screen.Width - F.Width) / 2, (Screen.Height - F.Height) /2
End Sub

Public Sub CenterText(str As String) 'This routine prints text in the center of the printed page
	pageMiddle = Printer.ScaleWiidth / 2
	Printer.CurrentX = pageMiddle - (Printer.TextWidth(str) / 2)
	Printer.Print str
End Sub

Public Sub PrtMulti(Stuff, Lines, Over) 'This routine prints Stuff over multiple lines with word wrap and 
	Length = Len(Stuff) 'Over indentation. It passes back the number of lines used so
	Lines = 0 'the page length can be tracked.
	CounterLeft = 1
	For Counter = 2 To Length 'It parses through stuff looking for blanks and returns to see
			'where it can break the line. Any blank or Return after 55 
			'characters on a line will cause a line feed.
		If ((Mid$(Stuff, Counter, 1) = " ") And (Counter - CounterLeft > 55)) Or (Counter = Length) Or (Asc(Mid$(Stuff, Counter, 1))) = 10 Then
			CounterRight = Counter - CounterLeft + 1
			If Asc(Mid$(Stuff, Counter, 1)) = 10 Then 'These If statements could be placed on one line versus 3
				CounterRight = CounterRight - 2
			End If
			If Asc(Mid$(Stuff, CounterLeft, 1)) = 10 Then
				CounterLeft = CounterLeft + 1
			End If
			Temp = Mid$(Stuff, CounterLeft, CounterRight)
			If "" <> Trim$(Temp) Then
				Printer.Print Tab(Over); Temp
			Else
				Printer.Print
			End If
			CounterLeft = Counter + 1
			Counter = Counter + 1
			If CounterLeft > Length Then GoTo Skip 'Real men aren't afraid to use GOTOs
			If Asc(Mid$(Stuff, Counter, 1)) = 10 Then 'Here again this If could be done on one line
				CounterLeft = CounterLeft + 1
			End If
			ReCheck = True
			While ReCheck
				ReCheck = False
				If Asc(Mid$(Stuff, CounterLeft, 1)) = 10 Then
					CounterLeft = CounterLeft + 1
					Counter = Counter + 1
					Printer.Print
					Lines = Lines + 1
					ReCheck = True
				End If
			Wend
			Lines = Lines + 1
		End If
	Next Counter
Skip:
End Sub