'See also http://members.aol.com/vikamat for more VB links

'Few useful functions for VB programmers
'all routines tested with Vb 3.0 and some with 4.0
' report bugs /problems to [[Email Removed]]



FUNCTION NumberOnlyChar (keyAscii AS INTEGER) AS INTEGER
'Author : Vikas Kamat
' Call this in KeyPress Event if you want only numbers , all others thrown away
' Addition of CONSTANT.BAS is assumed

     NumberOnlyChar = 0
     DIM PERIOD%
     PERIOD = ASC(".")
     SELECT CASE keyAscii
     CASE KEY_BACK, PERIOD:
           NumberOnlyChar = keyAscii
     CASE 48 TO 57:
           NumberOnlyChar = keyAscii
     END SELECT
END FUNCTION

'********************************************************

FUNCTION IsModal () AS INTEGER
'Determines if any of the forms is being run modally
'Author: Vikas Kamat

DIM WinStyle&, i
IsModal = False
'see if any of the windows has disbaled posted
FOR i = 0 TO Forms.Count - 1
  Debug.PRINT Forms(i).Caption
  WinStyle& = GetWindowLong(Forms(i).hWnd, GWL_STYLE)
  IF WinStyle& AND WS_DISABLED THEN
      IsModal = True
      'Exit Function
  END IF
NEXT i
END FUNCTION
'********************************************************
FUNCTION FeetInch2Feet (pLen AS SINGLE) AS SINGLE
'Converts Feet.Inch into real feet
'Eg: 15.6 becomes 15.5

DIM feetPart AS INTEGER
DIM InchPart AS INTEGER
DIM newOne AS SINGLE
feetPart = INT(pLen / 100)
InchPart = pLen - feetPart * 100
newOne = Format(feetPart + InchPart / 12, ".00")
FeetInch2Feet = newOne
END FUNCTION
'******************************************************
FUNCTION Dec2DMS (fInp AS DOUBLE) AS STRING
'Converts Geographical co-ordiantes in Decimal form
' to Degrees-Minutes-Seconds format

'Author John Biblo

DIM cDeg AS STRING
DIM cmin AS STRING
DIM imin AS INTEGER
DIM cSec
DIM fSecTemp AS SINGLE

cDeg = Str(ABS(fInp)  1)
imin = ABS(((ABS(fInp) / 1) - (ABS(fInp)  1)) * 60)  1
cmin = Str(imin)

fSecTemp = ABS(((ABS(fInp) / 1) - (ABS(fInp)  1)) * 60)
fSecTemp = fSecTemp - (fSecTemp / 1)

cSec = (fSecTemp * 60)  1
Dec2DMS = Trim(cDeg) & "-" & Format(imin, "00") & "-" & Format(cSec, "00")

END FUNCTION
'******************************************************

SUB PrintTextFileDirect (fileName AS STRING)
' Prints the argument string file to
' LPT1
'Printing a Text file on printer bypassing Print Manager

IF Dir(fileName) = "" THEN EXIT SUB
ON ERROR GOTO PrintFileErr

DIM inpLine  AS STRING

DIM FNumLp, FNumIp
FNumLp = FREEFILE
OPEN "LPT1" FOR OUTPUT AS #FNumLp

FNumIp = FREEFILE
OPEN fileName FOR INPUT AS #FNumIp

DO WHILE NOT EOF(FNumIp)
    LINE INPUT #FNumIp, inpLine ' Get complete line.
    PRINT #FNumLp, inpLine
LOOP
'goto the Next Page
PRINT #FNumLp, Chr(12) & Chr(13)

CLOSE #FNumLp
CLOSE #FNumIp
EXIT SUB
PrintFileErr:
    MsgBox ERROR(ERR) & " while printing File " & fileName
    CLOSE  ' Force a close
    EXIT SUB
END SUB

'******************************************************************
'Hassle free GetProfileString()

FUNCTION APIGetPrivateProfileString (Section$, KEY$, iniFileName$, Length%) AS STRING

'Hassle Free Private ProfileString
DIM ReturnText$, StringLength%

  ReturnText$ = STRING$(Length%, 0)   ' this takes care of most problems
  StringLength% = GetPrivateProfileString(Section$, KEY$, "", ReturnText$, Length%, iniFileName$)
  APIGetPrivateProfileString$ = LEFT$(ReturnText$, StringLength%)

END FUNCTION
'********************************************************************
'Parse function for delimited strings

FUNCTION GetField (linetext AS STRING, Position AS INTEGER,FS) AS STRING

' Great Parsing Function. Especially use to read from file
' Provide a delemited line and get any field you want
' So GetField ("Bill | Gates | would | make | a | lousy | President", 7,"|") would return "President"

   DIM i AS INTEGER
   DIM p AS INTEGER
   DIM q AS INTEGER
   ON ERROR RESUME NEXT
   FOR i = 1 TO Position - 1
      p = INSTR(p + 1, linetext, FS)
   NEXT i
   q = INSTR(p + 1, linetext, FS)
   IF q = 0 THEN q = LEN(linetext) + 1
   GetField = Mid(linetext, p + 1, (q - p) - 1) ' trade performance for simplicity :-|
END FUNCTION
'********************************************************************
FUNCTION FindStringInCB (c AS Control, s AS STRING) AS INTEGER

'Given Combo box and string,
'Positions and returns position

   DIM LPOS AS LONG
   CONST CB_FINDSTRING = &H40C
   LPOS = SendMessage(c.hWnd, CB_FINDSTRING, 0, BYVAL s)
   MyCBFindString = LPOS
END FUNCTION
DECLARE FUNCTION SendMessage& Lib "User" (BYVAL hWnd%, BYVAL wMsg%, BYVAL wParam%, lParam AS ANY)

'*******************************************************************

'Center Form
SUB CenterForm (FormName AS Form)
  DIM LeftPosition AS INTEGER, TopPosition AS INTEGER
  'vkk
  'Bug fix 4/25/95 if form is minimised or maximised
  IF (FormName.WindowState) THEN FormName.WindowState = 0
  LeftPosition = (SCREEN.WIDTH - FormName.WIDTH) / 2
  TopPosition = (SCREEN.Height - FormName.Height) / 2
  FormName.Move LeftPosition, TopPosition
END SUB

'******************************************************************
FUNCTION GetControlBoxHeight () AS INTEGER
  ' retuns the height of the Windows control Box
  ' (the left-top corner box)
  ' Vikas Kamat
  ' Sept '95
  DIM i AS INTEGER
  CONST SM_CYCAPTION = 4
  i = GetSystemMetrics(SM_CYCAPTION)
  GetControlBoxHeight = i * SCREEN.TwipsPerPixelY
END FUNCTION
DECLARE FUNCTION GetSystemMetrics Lib "User" (BYVAL nIndex AS INTEGER) AS INTEGER
'********************************************************************