Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
208 lines (176 sloc) 7.16 KB
Attribute VB_Name = "modFunctions"
Option Explicit
' declarations
Public Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function ShellExecute Lib "shell32" 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
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As Any, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Public Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Public Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Public 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
Private Type POINTAPI
X As Long
Y As Long
End Type
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
' constants:
Public Const m_strRegRoot = "SOFTWARE\Port Jackson Computing\Hours and Minutes"
' format milliseconds as "HH:MM:SS"
Public Function FormatMSeconds(ByVal lngMSeconds As Long)
Dim lngH As Long, lngM As Long
lngMSeconds = lngMSeconds \ 1000
lngH = lngMSeconds \ 60 \ 60
lngMSeconds = lngMSeconds - (lngH * 60 * 60)
lngM = lngMSeconds \ 60
lngMSeconds = lngMSeconds - (lngM * 60)
FormatMSeconds = IIf(lngH < 10, "0" & lngH, lngH) & ":" & IIf(lngM < 10, "0" & lngM, lngM) & ":" & IIf(lngMSeconds < 10, "0" & lngMSeconds, lngMSeconds)
End Function
' get milliseconds from a time
Public Function GetMSeconds(ByVal dteDate As Date) As Long
GetMSeconds = DatePart("s", dteDate) * 1000
GetMSeconds = GetMSeconds + DatePart("n", dteDate) * 60 * 1000
GetMSeconds = GetMSeconds + DatePart("h", dteDate) * 60 * 60 * 1000
End Function
' checks if a value is a integer value
Public Function isInteger(ByVal varValue As Variant) As Boolean
Dim X As Integer, strTemp As String
isInteger = False
strTemp = CStr(varValue)
If Len(strTemp) = 0 Then Exit Function
For X = 1 To Len(strTemp)
If Mid$(strTemp, X, 1) < "0" Or Mid$(strTemp, X, 1) > "9" Then Exit Function
Next
isInteger = True
End Function
' gets a input text from the user
Public Function getInput(objOwnerForm As Form, strPrompt As String, strTitle As String, strDefault As String) As String
getInput = ""
Load frmInput
With frmInput
.lblPrompt.Caption = strPrompt
.Caption = strTitle
.txtValue.Text = strDefault
.txtValue.SelStart = 0
.txtValue.SelLength = Len(.txtValue.Text)
.Show 1, objOwnerForm
If .m_blnCancelPressed = False Then getInput = Trim(.txtValue.Text)
End With
Unload frmInput
End Function
' shows a message to the user
Public Sub showMessage(strMessage As String, strTitle As String)
Dim X As Long
Dim blnShowMessagesModally As Boolean
blnShowMessagesModally = False
If Forms.Count > 1 Then blnShowMessagesModally = True
On Error Resume Next
With frmMessage
.AddMessage strMessage, strTitle
If blnShowMessagesModally = False Then
.Show 0
Else
.Show 1
End If
.SetFocus
End With
On Error GoTo 0
End Sub
' checks if a string (filename) contain invalid characters
Public Function containInvalidChars(strText As String) As Boolean
Dim strTemp As String, X As Long
containInvalidChars = True
For X = 1 To Len(strText)
strTemp = Mid$(strText, X, 1)
If strTemp = "\" Or strTemp = "/" Or strTemp = ":" Or strTemp = "*" Or strTemp = "?" Or strTemp = """" Or strTemp = "<" Or strTemp = ">" Or strTemp = "|" Then Exit Function
Next
containInvalidChars = False
End Function
' returns the name of the weekday for a date
Public Function DayName(dteDate As Date) As String
Select Case Weekday(dteDate)
Case 1: DayName = "Sunday"
Case 2: DayName = "Monday"
Case 3: DayName = "Tuesday"
Case 4: DayName = "Wednesday"
Case 5: DayName = "Thursday"
Case 6: DayName = "Friday"
Case 7: DayName = "Saturday"
End Select
End Function
' checks if a index exist within a collection
Public Function isInCollection(ByVal strIndex As String, ByRef colCollection As Collection) As Boolean
On Error GoTo lblErrorHandler
isInCollection = True
With colCollection.Item(strIndex)
End With
On Error GoTo 0
Exit Function
lblErrorHandler:
On Error GoTo 0
isInCollection = False
End Function
' returns the idle time in seconds (if called once every second)
Public Sub getIdleTime(lngTCount As Long, dteDate As Date, ByRef lngIdleTimeTotal As Long, ByRef lngIdleTimeToday As Long)
Static objOldPoint As POINTAPI
Static objLastRun As Variant
Static objLastDate As Variant, objLastRunDate As Variant
Dim objPoint As POINTAPI, X As Long, blnTemp As Boolean
lngIdleTimeTotal = 0
lngIdleTimeToday = 0
' check if cursor has been moved since last run
GetCursorPos objPoint
blnTemp = False
If objPoint.X <> objOldPoint.X Or objPoint.Y <> objOldPoint.Y Then
blnTemp = True
End If
For X = 1 To 255
If GetAsyncKeyState(X) <> 0 Then
blnTemp = True
End If
Next
If blnTemp = False Then
' idle
If IsEmpty(objLastRun) Then objLastRun = lngTCount
If IsEmpty(objLastDate) Then
objLastDate = dteDate
objLastRunDate = lngTCount
End If
If objLastDate <> dteDate Then
objLastDate = dteDate
objLastRunDate = lngTCount
End If
lngIdleTimeToday = lngTCount - objLastRunDate
lngIdleTimeTotal = lngTCount - objLastRun
Else
' active
objOldPoint = objPoint
objLastDate = Empty
objLastRun = Empty
objLastRunDate = Empty
End If
End Sub
' repeats a string # number of times
Public Function Repeat(strString As String, lngCount As Long) As String
Dim X As Long
Repeat = ""
For X = 1 To lngCount
Repeat = Repeat & strString
Next
End Function
' trims and includes crlf characters
Public Function TrimCRLF(strString As String) As String
While Right$(strString, 1) = vbCr Or Right$(strString, 1) = vbLf
strString = Trim$(Left$(strString, Len(strString) - 1))
Wend
While Left$(strString, 1) = vbCr Or Left$(strString, 1) = vbLf
strString = Trim$(Right$(strString, Len(strString) - 1))
Wend
TrimCRLF = Trim$(strString)
End Function
You can’t perform that action at this time.