home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / Callers_Ad2211429122011.psc / CallersAddin / Errors.bas < prev    next >
BASIC Source File  |  2011-08-07  |  5KB  |  113 lines
  1. Attribute VB_Name = "modErrors"
  2. Option Explicit                                    ' ⌐Rd
  3.  
  4. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  5. Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long ' ⌐Rd
  6. Private Declare Function GetModuleHandleZ Lib "kernel32" Alias "GetModuleHandleA" (ByVal hNull As Long) As Long
  7.  
  8. 'Randy Birch, VBnet.com
  9. Private Declare Function StrLenW Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
  10.  
  11. Private Const GWL_HINSTANCE = &HFFFFFFFA
  12. Private Const MAX_PATH As Long = 260
  13.  
  14. Private mFile As String
  15. Private mInit As Boolean
  16.  
  17. Public Sub InitErr(Optional sCompName As String, Optional ByVal fClearMsgLog As Boolean)
  18.   On Error GoTo Fail
  19.     Dim i As Integer
  20.     If Not mInit Then
  21.         mFile = RTrimChr(GetParentPath, "\") & "\" & sCompName
  22.         If fClearMsgLog Then
  23.             i = FreeFile()
  24.             Open mFile & "_Msg.log" For Output As #i
  25.             Close #i
  26.         End If
  27.         mInit = True
  28.     End If
  29. Fail:
  30. End Sub
  31.  
  32. Public Sub LogError(sProcName As String, Optional sExtraInfo As String)
  33.     Dim Num As Long, Src As String, Desc As String
  34.     With Err
  35.       Num = .Number: Src = .Source: Desc = .Description
  36.     End With
  37.   On Error GoTo Fail
  38.     If Erl Then Desc = Desc & vbNewLine & "Error on line " & Erl
  39.     If LenB(sExtraInfo) Then Desc = Desc & vbNewLine & sExtraInfo
  40.     If mInit Then Else InitErr
  41.     Dim i As Integer: i = FreeFile()
  42.     Open mFile & "_Error.log" For Append As #i
  43.         Print #i, Src; " error log ";
  44.         Print #i, Format$(Now, "h:nn:ss am/pm mmmm d, yyyy")
  45.         Print #i, sProcName; " error!"
  46.         Print #i, "Error #"; Num; " - "; Desc
  47.         Print #i, " * * * * * * * * * * * * * * * * * * *"
  48. Fail:
  49.     Close #i
  50.     Beep
  51. End Sub
  52.  
  53. Public Sub LogMsg(Msg As String)
  54.   On Error GoTo Fail
  55.     If mInit Then Else InitErr
  56.     Dim i As Integer: i = FreeFile()
  57.     Open mFile & "_Msg.log" For Append As #i
  58.         Print #i, Format$(Now, "h:nn:ss am/pm mmmm d, yyyy")
  59.         Print #i, Msg
  60.         Print #i, " * * * * * * * * * * * * * * * * * * *"
  61.     Close #i
  62. Fail:
  63. End Sub
  64.  
  65. Private Function GetParentPath() As String
  66.   On Error GoTo Fail
  67.     Dim sModName As String, hInst As Long, rc As Long
  68.     ' Get the application hInstance. By passing NULL, GetModuleHandle
  69.     ' returns a handle to the file used to create the calling process.
  70.     hInst = GetWindowLong(GetModuleHandleZ(0&), GWL_HINSTANCE)
  71.     ' Get the module file name
  72.     sModName = String$(MAX_PATH, vbNullChar)
  73.     rc = GetModuleFileName(hInst, sModName, MAX_PATH)
  74.     GetParentPath = TrimZ(sModName)
  75. Fail:
  76.     ' Return empty string on error
  77. End Function
  78.  
  79. Public Function TrimZ(StrZ As String) As String
  80.     ' StrZ = "strZstrZstrZstrZZ[ZZZZZZ]" >> TrimZ = "str"
  81.     ' StrZ = "strZ[ZZZZZZ]"              >> TrimZ = "str"
  82.     ' StrZ = "str  "                     >> TrimZ = "str  "
  83.     Dim lLen As Long
  84.     lLen = StrLenW(StrPtr(StrZ)) 'Randy Birch
  85.     TrimZ = LeftB$(StrZ, lLen + lLen) 'Rd
  86. End Function
  87.  
  88. ' ========================================================================
  89. ' This vb5 function removes from sStr the first occurrence from the right
  90. ' of the specified character(s) and everything following it, and returns just
  91. ' the start of the string up to but not including the specified character(s).
  92. ' It always searches from right to left starting at the end of sStr. If the
  93. ' character(s) does not exist in sStr then the whole of sStr is returned and
  94. ' lRetPos is set to Len(sStr) + 1. sChar defaults to a backslash if omitted.
  95. ' ========================================================================
  96. Public Function RTrimChr(sStr As String, Optional sChar As String = "\", Optional ByRef lRetPos As Long, _
  97.                                 Optional ByVal eCompare As VbCompareMethod = vbBinaryCompare) As String
  98.     Dim lPos As Long
  99.     ' Default to return the passed string
  100.     lRetPos = Len(sStr) + 1&
  101.     If LenB(sChar) Then
  102.         lPos = InStr(1&, sStr, sChar, eCompare)
  103.         Do Until lPos = 0&
  104.             lRetPos = lPos
  105.             lPos = InStr(lRetPos + 1&, sStr, sChar, eCompare)
  106.         Loop
  107.     End If
  108.     ' Return sStr w/o sChar and any following substring
  109.     RTrimChr = LeftB$(sStr, lRetPos + lRetPos - 2&)
  110. End Function
  111.  
  112. '     »»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»»    :¢)
  113.