• Home
 · 
• Data Structures
 · 
• A Must Have .bas File For VB Programming

A Must Have .bas File For VB Programming

A Must Have StartupModule.bas File. Lots Of Options.

Rate A Must Have .bas File For VB Programming

• 1
• 2
• 3
• 4
• 5

(7(7 Vote))

Attribute VB_Name = "StartupModule"
Option Explicit
Public DBa(1 To 100) As String
Public AppPath
Public DallorGet
Public FirstLoad
Public KeyBoardType
Public KeyBoardRepeatDelay
Public KeyBoardRepeatSpeed
Public KeyBoardCaretFlashSpeed
Public CurDate
Public Ret As String
Public ReturnINIdat
Public INIFileFound
Public ShortFName
Public title
Public FileInfoName As String
Public FileInfoPathName As String
Public FileInfoSize As String
Public FileInfoLastModified As String
Public FileInfoLastAccessed As String
Public FileInfoAttributeHidden As String
Public FileInfoAttributeSystem As String
Public FileInfoAttributeReadOnly As String
Public FileInfoAttributeArchive As String
Public FileInfoAttributeTemporary As String
Public FileInfoAttributeNormal As String
Public FileInfoAttributeCompressed As String
Public VBSysDir
Public DirChkSize
Public Cd_Rom
Public Msg
Public DatGet
Public Word
Public StartTime
Public WordD
Public WordK
Public Dat
Public DOt
Public IsFileThere
Public Playinfo
Public DelConFirm
Public FlPath
Public sDType
Public GetWinDir
Public FlName
Public ShortPN
Public GWinDir
Public SupSound
Public DriveFreeSpace
Public DOSWinActive As String
Public Const GW_HWNDNEXT = 2
Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_RAMDISK = 6
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_UNKNOWN = 0
Public Const AUDIO_NONE = 0
Public Const AUDIO_WAVE = 1
Public Const AUDIO_MIDI = 2
Public Const HWND_TOPMOST = -1
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Const WM_CLOSE = &H10
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const MF_BYPOSITION = &H400
Private Const MF_REMOVE = &H1000
Public Const SPI_GETKEYBOARDSPEED = 10
Public Const SPI_GETKEYBOARDDELAY = 22
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Declare Function GetWindowDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Declare Function EnumWindows Lib "user32" (ByVal wndenmprc As Long, ByVal lParam As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Declare Function GetKeyboardType Lib "user32" (ByVal nTypeFlag As Long) As Long
Declare Function GetCaretBlinkTime Lib "user32" () As Long

Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal aint As Integer) As Integer
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Integer) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function fCreateShellGroup Lib "STKIT432.DLL" _
(ByVal lpstrDirName As String) As Long
Private Declare Function fCreateShellLink Lib "STKIT432.DLL" _
(ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, _
ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long
Private Declare Function fRemoveShellLink Lib "STKIT432.DLL" _
(ByVal lpstrFolderName As String, ByVal lpstrLinkName As String) As Long
Private Type SHFILEOPSTRUCT
  hwnd As Long
  wFunc As Long
  pFrom As String
  pTo As String
  fFlags As Integer
  fAnyOperationsAborted As Boolean
  hNameMappings As Long
  lpszProgressTitle As String ' only used if FOF_SIMPLEPROGRESS
End Type

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Type FILETIME
  LowDateTime     As Long
  HighDateTime     As Long
End Type
Type WIN32_FIND_DATA
  dwFileAttributes   As Long
  ftCreationTime    As FILETIME
  ftLastAccessTime   As FILETIME
  ftLastWriteTime   As FILETIME
  nFileSizeHigh    As Long
  nFileSizeLow     As Long
  dwReserved0     As Long
  dwReserved1     As Long
  cFileName      As String * 260 'MUST be set to 260
  cAlternate      As String * 14
End Type

Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Type POINTAPI
    X As Long
    Y As Long
End Type
Const SWP_NOZORDER = &H4
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Const HKEY_LOCAL_MACHINE = &H80000002
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Const SND_ALIAS = &H10000
Public Const SND_ALIAS_ID = &H110000
Public Const SND_ALIAS_START = 0
Public Const SND_APPLICATION = &H80
Public Const SND_ASYNC = &H1
Public Const SND_FILENAME = &H20000
Public Const SND_LOOP = &H8
Public Const SND_MEMORY = &H4
Public Const SND_NODEFAULT = &H2
Public Const SND_NOSTOP = &H10
Public Const GWL_STYLE = (-16)
Public Const ES_NUMBER = &H2000
Public Const SND_NOWAIT = &H2000
Public Const SND_PURGE = &H40
Public Const SND_RESERVED = &HFF000000
Public Const SND_RESOURCE = &H40004
Public Const SND_SYNC = &H0
Public Const SND_TYPE_MASK = &H170007
Public Const SND_VALID = &H1F
Public Const SND_VALIDFLAGS = &H17201F
Private Const ERROR_SUCCESS = 0&
Private Const APINULL = 0&
Private ReturnCode As Long


Private Target As String
Private Type STARTUPINFO
  cb As Long
  lpReserved As String
  lpDesktop As String
  lpTitle As String
  dwX As Long
  dwY As Long
  dwXSize As Long
  dwYSize As Long
  dwXCountChars As Long
  dwYCountChars As Long
  dwFillAttribute As Long
  dwFlags As Long
  wShowWindow As Integer
  cbReserved2 As Integer
  lpReserved2 As Long
  hStdInput As Long
  hStdOutput As Long
  hStdError As Long
  End Type

Private Type PROCESS_INFORMATION
  hProcess As Long
  hThread As Long
  dwProcessID As Long
  dwThreadID As Long
  End Type
Global Const WM_USER = &H400
Global UserhWnd As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  Private Const NORMAL_PRIORITY_CLASS = &H20&
  Private Const INFINITE = -1&
Private Declare Function GetDriveTypeA Lib "kernel32" (ByVal nDrive As String) As Long
Private Declare Function DeleteObject Lib "gdi32" _
  (ByVal hObject As Long) As Long
  
Private lShowCursor As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
  
Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
  
Private Declare Function GetWindowsDirectoryA Lib "kernel32" _
  (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function waveOutGetNumDevs Lib "winmm" () As Long
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
   
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
  "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long




Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
              (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
               (ByVal hwnd As Long, ByVal nIndex As Long, _
               ByVal dwNewLong As Long) As Long

Declare Function GetActiveWindow Lib "user32" () As Long
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
Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function MoveWindow Lib "user32" _
               (ByVal hwnd As Long, _
               ByVal X As Long, ByVal Y As Long, _
               ByVal nWidth As Long, ByVal nHeight As Long, _
               ByVal bRepaint As Long) As Long
Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, _
ByVal lpstrBffer As String, ByVal uLength As Long) As Long
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Declare Function sndPlaySoundByte Lib "winmm.dll" Alias "sndPlaySoundA" _
    (lpszSoundName As Byte, ByVal uFlags As Long) As Long
    Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function Findfile(xstrfilename) As WIN32_FIND_DATA
Dim Win32Data As WIN32_FIND_DATA
Dim plngFirstFileHwnd As Long
Dim plngRtn As Long
plngFirstFileHwnd = FindFirstFile(xstrfilename, Win32Data) ' Get information of file using API call
If plngFirstFileHwnd = 0 Then
 Findfile.cFileName = "Error"               ' If file was not found, return error as name
Else
 Findfile = Win32Data                   ' Else return results
End If
plngRtn = FindClose(plngFirstFileHwnd)           ' It is important that you close the handle for FindFirstFile
End Function

Function REGGETSTRING$(hInKey As Long, ByVal subkey$, ByVal valname$)
  Dim v$, RetVal$, hSubKey As Long, dwType As Long, SZ As Long
  Dim r As Long
  RetVal$ = ""
  Const KEY_ALL_ACCESS As Long = &HF0063
  Const ERROR_SUCCESS As Long = 0
  Const REG_SZ As Long = 1
  r = RegOpenKeyEx(hInKey, subkey$, 0, KEY_ALL_ACCESS, hSubKey)
  If r <> ERROR_SUCCESS Then GoTo Quit_Now
  SZ = 256: v$ = String$(SZ, 0)
  r = RegQueryValueEx(hSubKey, valname$, 0, dwType, ByVal v$, SZ)
  If r = ERROR_SUCCESS And dwType = REG_SZ Then
    RetVal$ = Left$(v$, SZ)
    Else
    RetVal$ = "--Not String--"
  End If
  If hInKey = 0 Then r = RegCloseKey(hSubKey)
Quit_Now:
    REGGETSTRING$ = RetVal$
  End Function
Public Function ActiveConnection() As Boolean
'
'Usage:
'   ActiveConnection
'   Msgbox ActiveConnection 'True = Connected to Internet \ False = Not Connected to Internet
'
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
ActiveConnection = False
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\RemoteAccess", phkResult)
If ReturnCode = ERROR_SUCCESS Then
  hKey = phkResult
  lpValueName = "Remote Connection"
  lpReserved = APINULL
  lpType = APINULL
  lpData = APINULL
  lpcbData = APINULL
  ReturnCode = RegQueryValueEx(hKey, lpValueName, _
  lpReserved, lpType, ByVal lpData, lpcbData)
  lpcbData = Len(lpData)
  ReturnCode = RegQueryValueEx(hKey, lpValueName, _
  lpReserved, lpType, lpData, lpcbData)
  If ReturnCode = ERROR_SUCCESS Then
    If lpData = 0 Then
      ActiveConnection = False
    Else
      ActiveConnection = True
    End If
  End If
  RegCloseKey (hKey)
End If
End Function



Public Function EnumCallback(ByVal app_hWnd As Long, ByVal param As Long) As Long
Dim buf As String * 256
Dim title As String
Dim length As Long
  ' Get the window's title.
  length = GetWindowText(app_hWnd, buf, Len(buf))
  title = Left$(buf, length)
  ' See if this is the target window.
  If InStr(title, Target) <> 0 Then
    ' Kill the window.
    SendMessage app_hWnd, WM_CLOSE, 0, 0
  End If
  
  ' Continue searching.
  EnumCallback = 1
End Function



Public Function FindWindowPartial(ByVal TitlePart As String) As Long
'
'Used By FindDosWin
'
  Dim hWndTmp As Long
  Dim nRet As Integer
  Dim TitleTmp As String
  TitlePart = UCase$(TitlePart)
  hWndTmp = FindWindow(0&, 0&)
  
  Do Until hWndTmp = 0
    TitleTmp = Space$(256)
    nRet = GetWindowText(hWndTmp, TitleTmp, Len(TitleTmp))
    If nRet Then
      TitleTmp = UCase$(VBA.Left$(TitleTmp, nRet))
      If InStr(TitleTmp, TitlePart) Then
        FindWindowPartial = hWndTmp
        Exit Do
      End If
    End If
    hWndTmp = GetWindow(hWndTmp, GW_HWNDNEXT)
  Loop
End Function

Function GETCURRUSER() As String
'
'Usage:
'    USERNAME = GETCURRUSER()
'    Msgbox USERNAME
'
  GETCURRUSER = REGGETSTRING$(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion", "RegisteredOwner")
End Function
Function GETCURRORG() As String
'
'Usage:
'   GETCURRORG
'   Msgbox USERORG
'
  GETCURRORG = REGGETSTRING$(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion", "RegisteredOrganization")
End Function
Function STRIPNULLS(startStrg$) As String
 Dim c%, item$
 c% = 1
 Do
  If Mid$(startStrg$, c%, 1) = Chr$(0) Then
   item$ = Mid$(startStrg$, 1, c% - 1)
   startStrg$ = Mid$(startStrg$, c% + 1, Len(startStrg$))
   STRIPNULLS$ = item$
   Exit Function
  End If
  c% = c% + 1
 Loop
End Function
Function App_Path() As String
'
'Usage:
'   App_Path
'   msgbox App_Path
'
Dim X
  X = App.Path
  If Right$(X, 1) <> "\" Then X = X + "\"
  App_Path = UCase$(X)
End Function
Sub CenterForm(WhatForm As Form)
'
'Usage:
'   CenterForm Form1
'
  If WhatForm.WindowState <> 0 Then Exit Sub
  WhatForm.Move (Screen.Width - WhatForm.Width) \ 2, (Screen.Height - WhatForm.Height) \ 2
End Sub
Public Sub CenterFormTop(frm As Form)
'
'Usage:
'    CenterFormTop Form1
'
  With frm
   .Left = (Screen.Width - .Width) / 2
   .Top = (Screen.Height - .Height) / (Screen.Height)
  End With
End Sub
Public Sub CenterFormBottom(frm As Form)
'
'Usage:
'    CenterFormBottom Form1
'
  With frm
   .Left = (Screen.Width - .Width) / 2
   .Top = (Screen.Height - .Height)
  End With
End Sub
Public Sub CenterFormBottomRight(frm As Form)
'
'Usage:
'    CenterFormBottomRight Form1
'
  With frm
   .Left = (Screen.Width - .Width) / 1
   .Top = (Screen.Height - .Height)
  End With
End Sub
Public Sub CenterFormBottomLeft(frm As Form)
'
'Usage:
'    CenterFormBottomLeft Form1
'
  With frm
   .Left = 0
   .Top = (Screen.Height - .Height)
  End With
End Sub
Public Sub CenterFormTopRight(frmForm As Form)
'
'Usage:
'    CenterFormTopRight Form1
'
  With frmForm
   .Left = (Screen.Width - .Width) / 1
   .Top = (Screen.Height - .Height) / 2000
  End With
End Sub
Public Sub CenterFormTopLeft(frmForm As Form)
'
'Usage:
'    CenterFormTopLeft Form1
'
  With frmForm
   .Left = 0
   .Top = 0
  End With
End Sub
Sub DeKrypt()
'
'Usage:
'    Dat = "TEST"
'    DeKrypt
'    Msgbox WordD
'
Dim i, Strg$, h$, J$
WordD = ""
For i = 1 To Len(Dat)
 WordD = WordD & Chr(Asc(Mid(Dat, i, 1)) - 1)
Next i
End Sub
Sub Krypt()
'
'Usage:
'    Dat = "TEST"
'    Krypt
'    Msgbox WordK
'
Dim i, Strg$, h$, J$
WordK = ""
For i = 1 To Len(Dat)
 WordK = WordK & Chr(Asc(Mid(Dat, i, 1)) + 1)
Next i
End Sub
Sub Detect_CD_Rom()
'
'Usage:
'    Detect_CD_ROM
'    Msgbox CD_ROM
'
Dim r&, allDrives$, JustOneDrive$, pos%, DriveType&
Dim CDfound As Integer
  allDrives$ = Space$(64)
 r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)
  allDrives$ = Left$(allDrives$, r&)
  Do
   pos% = InStr(allDrives$, Chr$(0))
    If pos% Then
    JustOneDrive$ = Left$(allDrives$, pos%)
    allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))
    DriveType& = GetDriveType(JustOneDrive$)
    If DriveType& = DRIVE_CDROM Then
     CDfound% = True
      Exit Do
    End If
   End If
 Loop Until allDrives$ = "" Or DriveType& = DRIVE_CDROM
  If CDfound% Then
    Cd_Rom = Trim(UCase$(JustOneDrive$))
 Else: Cd_Rom = "?"
 End If
End Sub
Sub HandW(FORMID As Form)
'
'Form Hieght And Width
'
'Usage:
'   HandW Form1
'
Dim a, b
Dat = ""
a = FORMID.Height
b = FORMID.Width
Dat = "Hieght = " & a & " Width = " & b
Msg = Dat
MsgBx
End Sub
Sub LandT(FORMID As Form)
'
'Form Left And Top
'
'Usage:
'   LandT Form1
'
Dim a, b
Dat = ""
a = FORMID.Left
b = FORMID.Top
Dat = "Left = " & a & " Top = " & b
Msg = Dat
MsgBx
End Sub
Sub MidiPlay(NamePath As String)
'
'Usage:
'    MidiPlay "Test.mid"
'
OpenMidi NamePath
PlayMidi
End Sub
Sub OpenMidi(sfile As String)
'
'Used by MidiPlay SUB
'
Dim sShortFile As String * 67
Dim lResult As Long
Dim sError As String * 255
lResult = GetShortPathName(sfile, sShortFile, Len(sShortFile))
sfile = Left(sShortFile, lResult)
lResult = mciSendString("open " & sfile & " type sequencer alias mcitest", ByVal 0&, 0, 0)
If lResult Then
lResult = mciGetErrorString(lResult, sError, 255)
Debug.Print "open: " & sError
End If
End Sub
Sub PlayMidi()
'
'Used by MidiPlay SUB
'
Dim lResult As Integer
Dim sError As String * 255
lResult = mciSendString("play mcitest", ByVal 0&, 0, 0)
If lResult Then
lResult = mciGetErrorString(lResult, sError, 255)
Debug.Print "play: " & sError
End If
End Sub
Sub StopMidi()
'
'Usage:
'   StopMidi 'Stop Any Midi File Playing
'
Dim lResult As Integer
Dim sError As String * 255
lResult = mciSendString("close mcitest", "", 0&, 0&)
If lResult Then
lResult = mciGetErrorString(lResult, sError, 255)
Debug.Print "stop: " & sError
End If
End Sub
Sub Timeout(duration)
'
'Usage:
'   Timeout (1)
'
StartTime = Timer
Do While Timer - StartTime < duration
DoEvents
Loop
End Sub
Sub MsgBx()
'
'Usage:
'    Msg = "Test Message"
'    MsgBx
'
If Msg = "" Then
Msg = "NO MESSAGE TO DISPLAY"
End If
MsgBox Msg, vbOKOnly, title
End Sub
Sub YN_Msgbox()
'
'Usage:
'    Title = "Test Title"
'    Msg = "Quit?"
'    YN_Msgbox
'    If Word = "Y" then
'    Msgbox "Yes!"
'    End if
'    If Word = "N" then
'    Msgbox "No!"
'    End if
'
Dim style, CTXT, HELP, Response
Word = ""
style = vbYesNo + vbDefaultButton2
CTXT = 1000
Response = MsgBox(Msg, style, title, HELP, CTXT)
If Response = vbYes Then
  Word = "Y"
Else
  Word = "N"
End If
End Sub
Public Sub PlayWav(SFileName As String, Optional Mode)
'
'Usage:
'    PlayWav "test.wav",1 'Plays Wav With Out Delay.
'    PlayWav "test.wav",2 'Plays Wav With Delay.
'
  Dim lReturn As Long
  On Error GoTo ErrorHandleFile
  If IsMissing(Mode) Then Mode = SND_ASYNC Or SND_NODEFAULT
  If (Mode And SND_ALIAS) <> SND_ALIAS Then
    If Len(Dir(Trim$(SFileName))) = 0 Then
      Exit Sub
    End If
  End If
  lReturn = sndPlaySound(SFileName, Mode)
ErrorHandleFile:
End Sub
Sub StayOnTop(the As Form)
'
'Usage:
'    StayOnTop Form1
'
Dim SetWinOnTop%
SetWinOnTop = SetWindowPos(the.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
End Sub
Sub NumRND(NMBR As Long)
'
'Usage:
'    NumRND 999999999 'Nine Number Max.
'    Msgbox Dat
'
Randomize
Dat = Int(NMBR * Rnd)
End Sub
Sub NumTextOnly(KeyR)
'
'Usage:
'    NumTextOnly KeyAscii 'Place This Code In The TextBox_KeyPressed Sub
'
Const numbers$ = "0123456789"
  If KeyR <> 8 Then

    If InStr(numbers, Chr(KeyR)) = 0 Then
      KeyR = 0
      Exit Sub
    End If
  End If
End Sub
Sub NumTextOnlyWithDash(KeyR)
'
'Usage:
'    NumTextOnlyWithDash KeyAscii 'Place This Code In The TextBox_KeyPressed Sub
'
Const numbers$ = "0123456789-"
  If KeyR <> 8 Then

    If InStr(numbers, Chr(KeyR)) = 0 Then
      KeyR = 0
      Exit Sub
    End If
  End If
End Sub
Sub NumTextOnlyWithDOT(KeyR, DataText As textBox)
'
'Usage:
'    NumTextOnlyWithDOT KeyAscii, text1 'Place This Code In The TextBox_KeyPressed Sub
'
Dim a, b, c, USEdot
USEdot = True
If FirstLoad = True Then Exit Sub
a = Len(DataText)
b = 1
Do Until b = a
If b > a Then Exit Sub
c = Mid$(DataText, b, 1)
If c = "." Then
USEdot = False
End If
b = b + 1
Loop
Const numbers$ = "0123456789."
'If USEdot = False Then
'numbers$ = "0123456789"
'Else
'numbers$ = "0123456789."
'End If

  If KeyR <> 8 Then

    If InStr(numbers, Chr(KeyR)) = 0 Then
      KeyR = 0
      Exit Sub
    End If
  End If
End Sub

Sub FormRunLeft(the As Form)
'
'Usage:
'    FormRunLeft Form1
'
Dim counter
counter = the.Left
Do: DoEvents
  counter = counter + 100
  the.Left = counter
Loop Until counter >= Screen.Width + the.Width
End Sub
Sub FormRunRight(the As Form)
'
'Usage:
'    FormRunRight Form1
'
Dim counter
counter = the.Left
Do: DoEvents
  counter = counter + 100
  the.Left = the.Left - counter
Loop Until counter >= Screen.Width + the.Width
End Sub
Sub FormRunDown(the As Form)
'
'Usage:
'    FormRunDown Form1
'
Dim counter
counter = the.Top
Do: DoEvents
  counter = counter + 100
  the.Top = counter
Loop Until counter >= Screen.Width + the.Width
End Sub
Sub FormRunUp(the As Form)
'
'Usage:
'    FormRunUp Form1
'
Dim counter
counter = the.Top
Do: DoEvents
  counter = counter + 100
  the.Top = the.Top - counter
Loop Until counter >= Screen.Width + the.Width
End Sub
Sub FormRunLeftUp(the As Form)
'
'Usage:
'    FormRunLeftUp Form1
'
Dim counter
counter = the.Top
Do: DoEvents
  counter = counter + 100
  the.Left = the.Left - counter
  the.Top = the.Top - counter
Loop Until counter >= Screen.Width + the.Width
End Sub
Sub FormRunRightUp(the As Form)
'
'Usage:
'    FormRunRightUp Form1
'
Dim counter
counter = the.Top
Do: DoEvents
  counter = counter + 100
  the.Left = the.Left + counter
  the.Top = the.Top - counter
Loop Until counter >= Screen.Width + the.Width
End Sub
Sub FormRunRightDown(the As Form)
'
'Usage:
'    FormRunRightDown Form1
'
Dim counter
counter = the.Top
Do: DoEvents
  counter = counter + 100
  the.Left = the.Left + counter
  the.Top = the.Top + counter
Loop Until counter >= Screen.Width + the.Width
End Sub

Sub FormRunLeftDown(the As Form)
'
'Usage:
'    FormRunLeftDown Form1
'
Dim counter
counter = the.Top
Do: DoEvents
  counter = counter + 100
  the.Left = the.Left - counter
  the.Top = the.Top + counter
Loop Until counter >= Screen.Width + the.Width
End Sub
Sub LimitText(KeyR, LimitDat)
'
'Usage:
'    LimitText KeyAscii, "ABC.1" 'Place This Code In The TextBox_KeyPressed Sub
'
  ' Const
  Dim numbers$
  numbers$ = LimitDat

  If KeyR <> 8 Then

    If InStr(numbers, Chr(KeyR)) = 0 Then
      KeyR = 0
      Exit Sub
    End If
  End If
End Sub
Sub WebLink(WeBLnk)
'
'Usage:
'
Dim WL, nResult
WL = "start.exe " & WeBLnk
nResult = Shell(WL, vbHide)
End Sub

Public Sub ExecCmd(cmdline$)
'
' Shell the Application then
' Wait for the shelled application
' to finish.
'
'Usage:
'    ExecCmd "calc.exe"
'
  Dim proc As PROCESS_INFORMATION
  Dim start As STARTUPINFO
  Dim Ret&
  start.cb = Len(start)
  Ret& = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
  ' Wait for the shelled application to finish:
  Ret& = WaitForSingleObject(proc.hProcess, INFINITE)
  Ret& = CloseHandle(proc.hProcess)
End Sub

Sub DirSize(DirChk)
'
'Usage:
'    DirSize "c:\windows"
'    Msg = "Total bytes used = " + DirChkSize
'    MsgBx
'
Dim FileName As String
Dim FileSize As Currency
Dim Directory As String
If Len(DirChk) = 3 Then
Directory = DirChk
Else
Directory = DirChk & "\"
End If
FileName = Dir$(Directory & "*.*")
FileSize = 0
Do While FileName <> ""
FileSize = FileSize + FileLen(Directory & FileName)
FileName = Dir$
Loop
DirChkSize = Str$(FileSize)
End Sub
Sub SupportSound()
'
'Usage:
'   SupportSound
'
'Return Value Supsound>> True = Yes - False = No
'
  Dim i As Integer
  i = waveOutGetNumDevs()
  If i > 0 Then
    SupSound = True
  Else
    SupSound = False
  End If
End Sub

Function WindowsSysDir() As String
'
'Usage:
'   WindowsSysDir
'   Msg = VBSysDir
'   msgbx
'
  Dim Gwdvar As String, Gwdvar_Length As Integer
  Gwdvar = Space(255)
  Gwdvar_Length = GetSystemDirectory(Gwdvar, 255)
  VBSysDir = Left(Gwdvar, Gwdvar_Length)
End Function

Public Function AddBackslash(s As String) As String
'
'Used By Other Sub's
'
  If Len(s) > 0 Then
   If Right$(s, 1) <> "\" Then
     AddBackslash = s + "\"
   Else
     AddBackslash = s
   End If
  Else
   AddBackslash = "\"
  End If
End Function
  
Public Function RemoveBackslash(s As String) As String
'
'Used By Other Sub's
'
  Dim i As Integer
  i = Len(s)
  If i <> 0 Then
   If Right$(s, 1) = "\" Then
     RemoveBackslash = Left$(s, i - 1)
   Else
     RemoveBackslash = s
   End If
  Else
   RemoveBackslash = ""
  End If
End Function
  
Public Function GetWindowsDirectory() As String
'
'Usage:
'   GetWindowsDirectory
'   Msgbox GetWinDir
'
  Dim s As String
  Dim i As Integer
 i = GetWindowsDirectoryA("", 0)
  s = Space(i)
  Call GetWindowsDirectoryA(s, i)
  GetWinDir = AddBackslash(Left$(s, i - 1))
End Function

Public Function FileExists(ByVal strPathName As String) As Integer
'
'Usage:
'   FileExists "c:\test.exe"
'   MsgBox IsFileThere
'
  Dim intFileNum As Integer
  On Error Resume Next
  If Right$(strPathName, 1) = "\" Then
    strPathName = Left$(strPathName, Len(strPathName) - 1)
  End If
  intFileNum = FreeFile
  Open strPathName For Input As intFileNum
  IsFileThere = IIf(Err, False, True)
  
  Close intFileNum
  Err = 0
End Function
Public Function GetPath(s As String) As String
'
'Usage:
'   GetPath "c:\t.bat"
'   MsgBox FlPath
'
  Dim i As Integer
  Dim J As Integer
  
  i = 0
  J = 0
  
  i = InStr(s, "\")
  Do While i <> 0
   J = i
   i = InStr(J + 1, s, "\")
  Loop
  
  If J = 0 Then
   FlPath = ""
  Else
   FlPath = Left$(s, J)
  End If
End Function
Public Function GetFile(s As String) As String
'
'Usage:
'   GetFile "c:\t.bat"
'   MsgBox FlName
'
  Dim i As Integer
  Dim J As Integer
  
  i = 0
  J = 0
  
  i = InStr(s, "\")
  Do While i <> 0
   J = i
   i = InStr(J + 1, s, "\")
  Loop
  
  If J = 0 Then
   FlName = ""
  Else
   FlName = Right$(s, Len(s) - J)
  End If
End Function


Public Function sDriveType(sDrive As String) As String
'
'Usage:
'   sDriveType "c"
'   MsgBox sDType
'
Dim lRet As Long
  lRet = GetDriveTypeA(sDrive & ":\")
  Select Case lRet
    Case 0
      sDType = "Unknown"
      
    Case 1
      sDType = "Drive Not Found"
    Case DRIVE_CDROM:
      sDType = "CD-ROM Drive"
      
    Case DRIVE_REMOVABLE:
      sDType = "Removable Drive"
      
    Case DRIVE_FIXED:
      sDType = "Fixed Drive"
      
    Case DRIVE_REMOTE:
      sDType = "Remote Drive"
    End Select
End Function
Public Function ShellDelete(ParamArray vntFileName() As Variant) As Boolean
'
'Usage:
'   ShellDelete "c:\test.exe"
'
  Dim i As Integer
  Dim sFileNames As String
  Dim SHFileOp As SHFILEOPSTRUCT
  For i = LBound(vntFileName) To UBound(vntFileName)
   sFileNames = sFileNames & vntFileName(i) & vbNullChar
  Next
    
  sFileNames = sFileNames & vbNullChar
  With SHFileOp
   .wFunc = FO_DELETE
   .pFrom = sFileNames
   .fFlags = FOF_ALLOWUNDO + FOF_SILENT + FOF_NOCONFIRMATION
  End With
  i = SHFileOperation(SHFileOp)
  
  If i = 0 Then
   DelConFirm = True
  Else
   DelConFirm = False
  End If
End Function
Public Sub ShadeForm(f As Form, Optional StartColor As Variant, Optional Fstep As Variant, Optional Cstep As Variant)
'
'Colors:
'    vbBlack
'    vbRed
'    vbGreen
'    vbYellow
'    vbBlue
'    vbMagenta
'    vbCyan
'    vbWhite
'
' StartColor is what color to start with.
'  (Default = vbBlue)
'
' Fstep is the number of steps to use to fill the form.
'  (Default = 64)
'
' Cstep is the color step (change in color per step).
'  (Default = 4)
'
'Usage:
'   ShadeForm StartUp, vbRed, 64, 4
'
  Dim FillStep As Single
  Dim c As Long
  Dim FillArea As RECT
  Dim i As Integer
  Dim oldm As Integer
  Dim hBrush As Long
  Dim C2(1 To 3) As Long
  Dim cs2(1 To 3) As Long
  Dim fs As Long
  Dim cs As Integer
   
  fs = IIf(IsMissing(Fstep), 64, CLng(Fstep))
  cs = IIf(IsMissing(Cstep), 4, CInt(Cstep))
  c = IIf(IsMissing(StartColor), vbBlue, CLng(StartColor))
  
  
  oldm = f.ScaleMode
  f.ScaleMode = vbPixels
  FillStep = f.ScaleHeight / fs
  FillArea.Left = 0
  FillArea.Right = f.ScaleWidth
  FillArea.Top = 0
  C2(1) = c And 255#
  cs2(1) = IIf(C2(1) > 0, cs, 0)
  C2(2) = (c \ 256#) And 255#
  cs2(2) = IIf(C2(2) > 0, cs, 0)
  C2(3) = (c \ 65536#) And 255#
  cs2(3) = IIf(C2(3) > 0, cs, 0)
  
  
  For i = 1 To fs
   FillArea.Bottom = FillStep * i
   hBrush = CreateSolidBrush(RGB(C2(1), C2(2), C2(3)))
   FillRect f.hdc, FillArea, hBrush
   DeleteObject hBrush
   
   C2(1) = (C2(1) - cs2(1)) And 255#
   C2(2) = (C2(2) - cs2(2)) And 255#
   C2(3) = (C2(3) - cs2(3)) And 255#
   
   FillArea.Top = FillArea.Bottom
  Next i
  
  f.ScaleMode = oldm
End Sub
Public Sub HideMouse()
'
'Usage:
'   HideMouse
'
  Dim result As Integer
  
  Do
   lShowCursor = lShowCursor - 1
   result = ShowCursor(False)
  Loop Until result < 0
  
End Sub
Public Sub ShowMouse()
'
'Usage:
'    ShowMouse
'
  If lShowCursor > 0 Then
   Do While lShowCursor <> 0
     ShowCursor (False)
     lShowCursor = lShowCursor - 1
   Loop
  ElseIf lShowCursor < 0 Then
   Do While lShowCursor <> 0
     ShowCursor (True)
     lShowCursor = lShowCursor + 1
   Loop
  End If
End Sub
Public Function CanPlaySound() As Integer
'
'Usage:
'    CanPlaySound
'    Msgbox Playinfo
'
  Dim i As Integer
  i = AUDIO_NONE
  
  If waveOutGetNumDevs > 0 Then
   i = AUDIO_WAVE
  End If
  
  If midiOutGetNumDevs > 0 Then
   i = i + AUDIO_MIDI
  End If
  If i = 1 Then Playinfo = "WAV ONLY"
  If i = 2 Then Playinfo = "MID ONLY"
  If i = 3 Then Playinfo = "WAV AND MID"
End Function
Public Sub GetBytes(ChkDrive)
'
'Usage:
'   GetBytes
'   Msgbox DriveFreeSpace
'
Dim ApiRes As Long
Dim SectorsPerCluster As Long
Dim BytesPerSector As Long
Dim NumberOfFreeClusters As Long
Dim TotalNumberOfClusters As Long
Dim FreeBytes As Long
Dim drvStr As String
Dim spaceInt As Integer
drvStr = ChkDrive
spaceInt = InStr(drvStr, " ")
If spaceInt > 0 Then drvStr = Left$(drvStr, spaceInt - 1)
If Right$(drvStr, 1) <> "\" Then drvStr = drvStr & "\"
Dim NumberOFreeClusters
ApiRes = GetDiskFreeSpace(drvStr, SectorsPerCluster, BytesPerSector, NumberOFreeClusters, TotalNumberOfClusters)
FreeBytes = NumberOFreeClusters * SectorsPerCluster * BytesPerSector
DriveFreeSpace = FreeBytes
End Sub

Public Sub FormatFloppy()
'
'Usage:
'   FormatFloppy
'
Dim sBuffer As String, Windir As String, Procs As String, X
Dim lResult As Long
Dim K
sBuffer = String$(255, 0)
lResult = GetWindowDirectory(sBuffer, Len(sBuffer))
Windir = Trim(sBuffer)
Procs = Left(Windir, lResult) & "\rundll32.exe shell32.dll,SHFormatDrive"
  Call CenterDialog("Format - 3½ Floppy (A:)")
  X = Shell(Procs, 1)
  Call CenterDialog("Format - 3½ Floppy (A:)")
K = LockWindowUpdate(0)
End Sub
Public Sub CenterDialog(WinText As String)
'
'This Sub Is Used By FormatFloppy
'
DoEvents
On Error Resume Next
Dim D3 As Long
D3 = LockWindowUpdate(GetDesktopWindow())
Dim wdth%
Dim hght%
Dim Scrwdth%
Dim Scrhght%
Dim lpDlgRect As RECT
Dim lpdskrect As RECT
Dim X%, Y%
Dim hTaskBar As Long
hTaskBar = FindWindow(0&, WinText)
  Call GetWindowRect(hTaskBar, lpDlgRect)
  wdth% = lpDlgRect.Right - lpDlgRect.Left
  hght% = lpDlgRect.Bottom - lpDlgRect.Top
  Call GetWindowRect(GetDesktopWindow(), lpdskrect)
  Scrwdth% = lpdskrect.Right - lpdskrect.Left
  Scrhght% = lpdskrect.Bottom - lpdskrect.Top
 
  X% = (Scrwdth% - wdth%) / 2
  Y% = (Scrhght% - hght%) / 2
  Call SetWindowPos(hTaskBar, 0, X%, Y%, 0, 0, SWP_NOZORDER Or SWP_NOSIZE)
DoEvents
End Sub

Public Sub ChkFileStats(File_Name_To_Chk)
'
'Usage:
'   ChkFileStats "C:\TEST.EXE"
'   MsgBox FileInfoName 'File Name Without Path
'   MsgBox FileInfoPathName ' File Name With Path
'   MsgBox FileInfoSize 'File Size
'   MsgBox FileInfoLastModified 'File Last Modified
'   MsgBox FileInfoLastAccessed 'File Last Accessed
'   MsgBox FileInfoAttributeHidden 'File Attribute Hidden? True/False
'   MsgBox FileInfoAttributeSystem 'File Attribute System? True/False
'   MsgBox FileInfoAttributeReadOnly 'File Attribute Read Only? True/False
'   MsgBox FileInfoAttributeArchive 'File Attribute Archive? True/False
'   MsgBox FileInfoAttributeTemporary 'File Attribute Temporary? True/False
'   MsgBox FileInfoAttributeNormal 'File Attribute Normal? True/False
'   MsgBox FileInfoAttributeCompressed 'File Attribute Compressed? True/False
'
Dim ftime As SYSTEMTIME
Dim tfilename As String
tfilename = File_Name_To_Chk
Dim filedata As WIN32_FIND_DATA
filedata = Findfile("c:\command.com")
FileInfoName = UCase$(File_Name_To_Chk)
FileInfoPathName = UCase$(tfilename)
GetFile FileInfoName
FileInfoName = FlName

If filedata.nFileSizeHigh = 0 Then
 
FileInfoSize = filedata.nFileSizeLow & " Bytes"
Else
FileInfoSize = filedata.nFileSizeHigh & "Bytes"
End If
Call FileTimeToSystemTime(filedata.ftCreationTime, ftime)
Call FileTimeToSystemTime(filedata.ftLastWriteTime, ftime)
FileInfoLastModified = ftime.wDay & "/" & ftime.wMonth & "/" & ftime.wYear
Call FileTimeToSystemTime(filedata.ftLastAccessTime, ftime)
FileInfoLastAccessed = ftime.wDay & "/" & ftime.wMonth & "/" & ftime.wYear


If (filedata.dwFileAttributes And FILE_ATTRIBUTE_HIDDEN) = FILE_ATTRIBUTE_HIDDEN Then
 
FileInfoAttributeHidden = True
Else
FileInfoAttributeHidden = False
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_SYSTEM) = FILE_ATTRIBUTE_SYSTEM Then
FileInfoAttributeSystem = True
Else
FileInfoAttributeSystem = False
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_READONLY) = FILE_ATTRIBUTE_READONLY Then
FileInfoAttributeReadOnly = True
Else
FileInfoAttributeReadOnly = False
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_ARCHIVE) = FILE_ATTRIBUTE_ARCHIVE Then
FileInfoAttributeArchive = True
Else
FileInfoAttributeArchive = False
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_TEMPORARY) = FILE_ATTRIBUTE_TEMPORARY Then
FileInfoAttributeTemporary = True
Else
FileInfoAttributeTemporary = True
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_NORMAL) = FILE_ATTRIBUTE_NORMAL Then
FileInfoAttributeNormal = True
Else
FileInfoAttributeNormal = False
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_COMPRESSED) = FILE_ATTRIBUTE_COMPRESSED Then
FileInfoAttributeCompressed = True
Else
FileInfoAttributeCompressed = False
End If
End Sub

Public Sub FindDosWin(ByVal WndCap As String)
'
'Usage:
'    FindDosWin UCase$(Text11.Text)
'    Msgbox DOSWinActive 'True = DOS Window Is Active \ False = DOS Window Is Not Active
'
  Dim hWndFrame As Long
  hWndFrame = FindWindowPartial(WndCap)
  If hWndFrame = 0 Then
    DOSWinActive = False
    Exit Sub
  End If
  DOSWinActive = True
  End Sub

 
Sub makeShortCut(sExecutable As String, sShortcut, sArguments, PlaceInWhere)
'
'Usage:
'    makeShortCut "c:\test.exe", Testexe, "", (DESKTOP or STARTMENU or PATH TO PLACE SHORTCUT)
'
On Error GoTo py
Dim lRet As Integer
Dim DestPth, CreatedPth
PlaceInWhere = UCase$(PlaceInWhere)

Short_Name sExecutable
sExecutable = ShortFName
FileExists sExecutable
If IsFileThere = False Then
Msg = "ERROR! Short Cut File You Want To Link To Does Not Exists"
MsgBx
Exit Sub
End If
If PlaceInWhere = "STARTMENU" Then
lRet = fCreateShellLink("", sShortcut, sExecutable, sArguments)
Exit Sub
End If
GetWindowsDirectory
If PlaceInWhere = "DESKTOP" Then
CreatedPth = GetWinDir & "startm~1\programs\" & sShortcut & ".pif"
DestPth = GetWinDir & "desktop\" & sShortcut & ".pif"
Else
CreatedPth = GetWinDir & "startm~1\programs\" & sShortcut & ".pif"
DestPth = PlaceInWhere & sShortcut & ".pif"
lRet = fCreateShellLink("", sShortcut, sExecutable, sArguments)
End If


If PlaceInWhere = "DESKTOP" Then
FileExists DestPth
If IsFileThere = True Then
ShellDelete DestPth
End If
lRet = fCreateShellLink("", sShortcut, sExecutable, sArguments)
End If
Name CreatedPth As DestPth
Exit Sub
py:

End Sub

Public Function Short_Name(Long_Path As String) As String
'
'Usage:
'    Short_Name "C:\PathNameToProgram\test.exe"
'ShortFname
  Dim Short_Path As String
  Dim Answer As Long
  Short_Path = Space(250)
  Answer = GetShortPathName(Long_Path, Short_Path, Len(Short_Path))
  ShortFName = Left$(Short_Path, Answer)

End Function
Public Sub TerminateTask(app_name As String)
'
'Usage:
'   TerminateTask "Active WIndow Name You Want To Kill"
'
  Target = app_name
  EnumWindows AddressOf EnumCallback, 0
End Sub

Public Sub WriteINI(FileName As String, Section As String, Key As String, Text As String)
'
'Usage:
'    WriteINI "c:\test.ini", "section name", "key name", "text data"
'
WritePrivateProfileString Section, Key, Text, FileName
End Sub
Public Function ReadINI(FileName As String, Section As String, Key As String)
'
'Usage:
'    ReturnINIdat = ReadINI("c:\test.ini", "section name", "key name")
'    Msgbox INIFileFound 'True = File Found \ False = File Found
Dim RetLen
INIFileFound = True
FileExists FileName
If IsFileThere = False Then
INIFileFound = False
Exit Function
End If
Ret = Space$(255)
RetLen = GetPrivateProfileString(Section, Key, "", Ret, Len(Ret), FileName)
Ret = Left$(Ret, RetLen)
ReadINI = Ret
End Function

Sub GetKeyboardInfo()
Dim r As Long
Dim t As String
Dim K As Long
Dim Q As Long
K = GetKeyboardType(0)
If K = 1 Then t = "PC or compatible 83-key keyboard"
If K = 2 Then t = "Olivetti 102-key keyboard"
If K = 3 Then t = "AT or compatible 84-key keyboard"
If K = 4 Then t = "Enhanced(IBM) 101-102-key keyboard"
If K = 5 Then t = "Nokia 1050 keyboard"
If K = 6 Then t = "Nokia 9140 keyboard"
If K = 7 Then t = "Japanese keyboard"
KeyBoardType = t
Q = SystemParametersInfo(SPI_GETKEYBOARDDELAY, 0, r, 0)
KeyBoardRepeatDelay = r
Q = SystemParametersInfo(SPI_GETKEYBOARDSPEED, 0, r, 0)
KeyBoardRepeatSpeed = r
KeyBoardCaretFlashSpeed = GetCaretBlinkTime
End Sub
'here
Sub OpenCD_ROMDoor()
'
'Usage:
'   OpenCD_ROMDoor
'
'retvalue = mciSendString("set CDAudio door open", returnstring, 127, 0)
End Sub
Sub CloseCD_ROMDoor()
'
'Usage:
'   CloseCD_ROMDoor
'
'retvalue = mciSendString("set CDAudio door closed", returnstring, 127, 0)
End Sub

Sub Search32(dPath$, dpattern$, SFileName)
'
'Usage:
'    Search32 "C:\", "*.WAV", "c:\DIR.TXT"
'          |    |    |             |    |    Name Of File To Save Files Found.
'          |    Files To Search For Wildcards Can Be Used.
'          Directory To Start Search In. If Path = "C:\Windows" The Search Will Search
'          The Windows Directory Then All It's Sub Directories.
'
Close #10
Open SFileName For Output As 10
Call dirloop(dPath$, dpattern$)
Close #10
End Sub


Sub dirloop(thispath As String, thispattern As String)
'
'Used By Search32
'
  Dim thisfile, thesefiles, thesedirs, X, checkfile
  If Right$(thispath, 1) <> "\" Then thispath = thispath + "\"
  thisfile = Dir$(thispath + thispattern, 0)
  Do While thisfile <> ""
    Print #10, LCase$(thispath + thisfile)
    thisfile = Dir$
  Loop
 
  thisfile = Dir$(thispath + "*.", 0)
  thesefiles = 0
  ReDim filelist(10)
  Do While thisfile <> ""
    thesefiles = thesefiles + 1
    If (thesefiles Mod 10) = 0 Then
      ReDim Preserve filelist(thesefiles + 10)
    End If
    filelist(thesefiles) = thisfile
    thisfile = Dir$
  Loop
  thisfile = Dir$(thispath + "*.", 16)
  checkfile = 1
  thesedirs = 0
  ReDim dirlist(10)
  Do While thisfile <> ""
    If thisfile = "." Or thisfile = ".." Then
    ElseIf thisfile = filelist(checkfile) Then
      checkfile = checkfile + 1
    Else
      thesedirs = thesedirs + 1
      If (thesedirs Mod 10) = 0 Then ReDim Preserve dirlist(thesedirs + 10)
      dirlist(thesedirs) = thisfile
    End If
    thisfile = Dir$
  Loop
  
  For X = 1 To thesedirs
    Call dirloop(thispath + dirlist(X), thispattern): DoEvents
    Next X
End Sub
Sub GetDate()
'Usage:
'   GetDate
'
' CurDate = Current Computer Date
'
CurDate = Date
End Sub

Sub ClearAllTextBoxes(frmTarget As Form)
'Usage:
'    ClearAllTextBoxes Form1
'
Dim i, ctrltarget
  For i = 0 To (frmTarget.Controls.Count - 1)
    Set ctrltarget = frmTarget.Controls(i)
    If TypeOf ctrltarget Is textBox Then
      ctrltarget.Text = ""
    End If
  Next i
End Sub

Sub GetAPPpath()
Dim X
  X = App.Path
  If Right$(X, 1) <> "\" Then X = X + "\"
  AppPath = UCase$(X)
End Sub
Sub DallorPeriodSet(Tdat As textBox)
'Usage:
'
'   DallorPeriodSet Text1
'   msgbox DallorGet
'
Dim a, b, Mrk1, c, d, C1, C2, C3, C4, C5
DallorGet = "0"
If Tdat = "" Or Val(Tdat) = 0 Then Exit Sub
Mrk1 = False
a = Len(Tdat.Text) + 1
b = 1
d = 0
Do Until b = a
c = Mid$(Tdat, b, 1)
If c = "." Then Mrk1 = True
If Mrk1 = True Then d = d + 1
DBa(b) = c

b = b + 1
Loop
d = d - 1
If d = 0 Then d = 2
c = Tdat
'no period
If d = -1 And Mrk1 = False Then
c = c & ".00"
DallorGet = c
Exit Sub
End If
'over flow 5.00573
If d > 2 Then
Dim v
d = False
For b = Len(c) To 1 Step -1
If DBa(b) = "." Then
Else
If Val(DBa(b)) >= 5 Then
If b - 2 <= 0 Then
'
Else
If DBa(b - 2) = "." Then
d = True
Else
If b - 1 <= 0 Then
'
Else
If d = False Then DBa(b - 1) = Val(DBa(b - 1)) + 1
End If
End If
End If
End If
Dim t, Y
Y = c
c = ""
For t = 1 To Len(Y)
c = c & DBa(t)
Next t
End If
Next b
Dim e, f
a = 1
b = ""
e = 0
Mrk1 = False
Do Until a = Len(c) + 1
d = Mid$(c, a, 1)
If d = "." Then Mrk1 = True
If Mrk1 = False Then f = f & d
If Mrk1 = True And e <= 2 Then
f = f & d
e = e + 1
End If
a = a + 1
Loop
DallorClean f
f = DallorGet
DallorGet = f
Exit Sub
End If
For b = 1 To d
c = c & "0"
Next b
DallorClean c
c = DallorGet
DallorGet = c

End Sub
Sub DallorClean(DDat)
On Error GoTo yu
Dim a, b, c, f, Mrk1
DallorGet = ""
a = 1
c = 0
Mrk1 = False
Do Until a = Len(DDat) + 1
b = Mid$(DDat, a, 1)
If b = "." Then Mrk1 = True
If Mrk1 = False Then f = f & b
If Mrk1 = True Then
c = c + 1
If c <= 3 Then
f = f & b
End If
End If
a = a + 1
Loop
a = 1
Mrk1 = False
Do Until a = Len(f) + 1
If Mid$(f, a, 1) = "." Then
b = a
Mrk1 = True
End If

a = a + 1
Loop
'If Mrk1 = False Then f = f & "."
If Val(Mid$(f, b, Len(f))) = 3 Then f = f & "00"
If Val(Mid$(f, b, Len(f))) = 4 Then f = f & "0"

If Mrk1 = False Then f = f & ".00"
DallorGet = f
Exit Sub
yu:
Exit Sub
End Sub
Sub addletter(frm As Form, newletter As String, oldcaption As String)
'Used By AnimateCaption
  Dim total As Integer, spaces As Integer, temp, X
  total = Len(temp)
  spaces = (frm.Width / 50) - (total)
  For X = spaces To Len(temp) Step -1
    frm.Caption = oldcaption & Space(X) & newletter
    DoEvents
    Next X
  End Sub

Sub AnimateCaption(CapData, MEfrm As Form)
'Usage:
'
'   AnimateCaption Form1
'
 MEfrm.Show
  MEfrm.Caption = ""
  Dim a, t
  a = CapData
  For t = 1 To Len(a)
  addletter MEfrm, Mid$(a, t, 1), MEfrm.Caption
  Next t
End Sub

      
Sub DisableX(FormNameHere As Form)
'Usage:
'
'   DisableX Form1
'
 Dim hMenu As Long
  Dim menuItemCount As Long
  hMenu = GetSystemMenu(FormNameHere.hwnd, 0)
  If hMenu Then
   menuItemCount = GetMenuItemCount(hMenu)
   Call RemoveMenu(hMenu, menuItemCount - 1, MF_REMOVE Or MF_BYPOSITION)
   Call RemoveMenu(hMenu, menuItemCount - 2, MF_REMOVE Or MF_BYPOSITION)
   Call DrawMenuBar(FormNameHere.hwnd)
  End If
 
End Sub