VB icon

Debugging compiled IDE exception functions

Email
Submitted on: 3/16/2018 8:22:31 AM
By: Nicholas Forystek  
Level: Intermediate
User Rating: Unrated
Compatibility: VB 6.0
Views: 1367
author picture
 
     This code is of a montage of crucial functions I've come to like to have on hand in VBIDE use and debugging. They are program environment exceptions specific to the VB IDE in analysis and are extra especially fault case two test incapable to me, because it makes for a better residing experience in the scenario basis of environment aware applicant development and implementation. The functions are simply said as put IsCompiled, IsCompiler, IsDebugger, IsRunMode, IsRunningMode, IsDesignMode, IsBreakMode, AppExeName and AppPath. Please see comments in the functions for more information on specifics if you have questions.
 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
				
'**************************************
' Name: Debugging compiled IDE exception functions
' Description:This code is of a montage of crucial functions I've come to like to have on hand in VBIDE use and debugging. They are program environment exceptions specific to the VB IDE in analysis and are extra especially fault case two test incapable to me, because it makes for a better residing experience in the scenario basis of environment aware applicant development and implementation. The functions are simply said as put IsCompiled, IsCompiler, IsDebugger, IsRunMode, IsRunningMode, IsDesignMode, IsBreakMode, AppExeName and AppPath. Please see comments in the functions for more information on specifics if you have questions.
' By: Nicholas Forystek
'**************************************

Option Explicit
Option Compare Binary
Option Private Module
Private Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As Long, ByVal lParam As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private IsDebugState As Variant
Private IsDebugCount As Long
Private IsDebugHwnds As String
Public Function IsDesignMode() As Boolean
'tests to see if the current vbide environment is in [design] mode
'that is in no project running, nor compiling and no design loading
Dim TmpHwnds As String
IsDebugHwnds = ""
IsDebugState = 0
EnumWindows AddressOf IsDebuggingWinEvents, GetCurrentProcessId
Do Until (IsDebugState <> 0) Or ((IsDebugHwnds = TmpHwnds & IsDebugHwnds) And (TmpHwnds = ""))
TmpHwnds = TmpHwnds & IsDebugHwnds
DoEvents
If InStr(IsDebugHwnds, TmpHwnds) > 0 Then
IsDebugHwnds = TmpHwnds
TmpHwnds = IsDebugHwnds & IsDebugHwnds
Else
TmpHwnds = ""
End If
Loop
IsDesignMode = (IsDebugState = 1)
End Function
Public Function IsRunningMode() As Boolean
'tests to see if the current vbide environment is in [running] mode
'that is in no project in idle design, active run, nor compiling
'running mode is inbetween the loading of a forms designer starts at
'[design] then you double click the form, then [running] occurs,
'and it becomes displayed, and the environment is back to [design]
'usercontrols can be seen executing property read and write functions
'by a line break on inside read properties and clicking open the form
Dim TmpHwnds As String
IsDebugHwnds = ""
IsDebugState = 0
EnumWindows AddressOf IsDebuggingWinEvents, GetCurrentProcessId
Do Until (IsDebugState <> 0) Or ((IsDebugHwnds = TmpHwnds & IsDebugHwnds) And (TmpHwnds = ""))
TmpHwnds = TmpHwnds & IsDebugHwnds
DoEvents
If InStr(IsDebugHwnds, TmpHwnds) > 0 Then
IsDebugHwnds = TmpHwnds
TmpHwnds = IsDebugHwnds & IsDebugHwnds
Else
TmpHwnds = ""
End If
Loop
IsRunningMode = (IsDebugState = 2)
End Function
Public Function IsRunMode() As Boolean
'[run] mode is when the project is in active debugging
'and the project is not in a break or stopped, it will
Dim TmpHwnds As String
IsDebugHwnds = ""
IsDebugState = 0
EnumWindows AddressOf IsDebuggingWinEvents, GetCurrentProcessId
Do Until (IsDebugState <> 0) Or ((IsDebugHwnds = TmpHwnds & IsDebugHwnds) And (TmpHwnds = ""))
TmpHwnds = TmpHwnds & IsDebugHwnds
DoEvents
If InStr(IsDebugHwnds, TmpHwnds) > 0 Then
IsDebugHwnds = TmpHwnds
TmpHwnds = IsDebugHwnds & IsDebugHwnds
Else
TmpHwnds = ""
End If
Loop
IsRunMode = (IsDebugState = 3)
End Function
Public Function IsBreakMode() As Boolean
'[break] mode is when a project is in active run but stalled and able
'edit while not in code execution from a Stop command or pause button
Dim TmpHwnds As String
IsDebugHwnds = ""
IsDebugState = 0
EnumWindows AddressOf IsDebuggingWinEvents, GetCurrentProcessId
Do Until (IsDebugState <> 0) Or ((IsDebugHwnds = TmpHwnds & IsDebugHwnds) And (TmpHwnds = ""))
TmpHwnds = TmpHwnds & IsDebugHwnds
DoEvents
If InStr(IsDebugHwnds, TmpHwnds) > 0 Then
IsDebugHwnds = TmpHwnds
TmpHwnds = IsDebugHwnds & IsDebugHwnds
Else
TmpHwnds = ""
End If
Loop
IsBreakMode = (IsDebugState = 4)
End Function
Private Function IsDebuggingWinEvents(ByVal hwnd As Long, ByVal lParam As Long) As Boolean
'private function
Dim txt As String
Dim lSize As Long
txt = Space$(255)
lSize = Len(txt)
Call GetWindowText(hwnd, txt, lSize)
If lSize > 0 Then
txt = Trim(Replace(Left$(txt, lSize), Chr(0), ""))
End If
IsDebugHwnds = IsDebugHwnds & hwnd & " "
If TypeName(IsDebugState) = "String" Then
If (InStr(txt, IsDebugState) > 0) Then
IsDebugState = "TRUE"
Else
IsDebuggingWinEvents = (Not (IsDebugState = "TRUE"))
EnumChildWindows hwnd, AddressOf IsDebuggingWinChildEvents1, lParam
End If
ElseIf (InStr(txt, "Microsoft Visual Basic [design]") > 0) Then
IsDebugState = 1
ElseIf (InStr(txt, "Microsoft Visual Basic [running]") > 0) Then
IsDebugState = 2
ElseIf (InStr(txt, "Microsoft Visual Basic [run]") > 0) Then
IsDebugState = 3
ElseIf (InStr(txt, "Microsoft Visual Basic [break]") > 0) Then
IsDebugState = 4
Else
IsDebuggingWinEvents = (Not (IsDebugState <> 0))
EnumChildWindows hwnd, AddressOf IsDebuggingWinChildEvents1, lParam
End If
End Function
Private Function IsDebuggingWinChildEvents1(ByVal hwnd As Long, ByVal lParam As Long) As Boolean
'private function
Dim txt As String
Dim lSize As Long
txt = Space$(255)
lSize = Len(txt)
Call GetWindowText(hwnd, txt, lSize)
If lSize > 0 Then
txt = Trim(Replace(Left$(txt, lSize), Chr(0), ""))
End If
IsDebugHwnds = IsDebugHwnds & hwnd & " "
If TypeName(IsDebugState) = "String" Then
If (InStr(txt, IsDebugState) > 0) Then
IsDebugState = "TRUE"
Else
IsDebuggingWinChildEvents1 = (Not (IsDebugState = "TRUE"))
End If
ElseIf (InStr(txt, "Microsoft Visual Basic [design]") > 0) Then
IsDebugState = 1
ElseIf (InStr(txt, "Microsoft Visual Basic [running]") > 0) Then
IsDebugState = 2
ElseIf (InStr(txt, "Microsoft Visual Basic [run]") > 0) Then
IsDebugState = 3
ElseIf (InStr(txt, "Microsoft Visual Basic [break]") > 0) Then
IsDebugState = 4
Else
IsDebuggingWinChildEvents1 = (Not (IsDebugState <> 0))
End If
End Function
Public Function AppPath(Optional ByVal RootEXEOf As Boolean = False) As String
'made to act similar to app.path with out he "dot" and optionally has the
'able exe or rather immediate possible dll of the callie being the return
'information, a dll linked to in the system folder would return the system32
'folder and the rootexeof=true would be the dll's executing parent processes
'settings /d VBIDE=0 on compiles or CondComp="VBIDE=-1" on properties replaces
'Projects with Binary to reflect euqal level Bin and Src type of path schema
Dim nLen As String
Dim lpTemp As String
If RootEXEOf Then
lpTemp = Space(256)
nLen = GetModuleFileName(0&, lpTemp, Len(lpTemp))
lpTemp = Trim(Left(lpTemp, nLen))
If InStrRev(lpTemp, "\") > 0 Then
lpTemp = Left(lpTemp, InStrRev(lpTemp, "\") - 1)
End If
If Right(lpTemp, 1) <> "\" Then lpTemp = lpTemp & "\"
Else
lpTemp = IIf((Right(App.Path, 1) = "\"), App.Path, App.Path & "\")
End If
#If VBIDE Then
If LCase(Right(lpTemp, 9)) = "projects\" Then
lpTemp = Replace(lpTemp, "Projects\", "Binary\", , , vbTextCompare)
 End If
#End If
AppPath = lpTemp
End Function
Public Function AppEXEName(Optional ByVal TitleOnly As Boolean = True, Optional ByVal RootEXEOf As Boolean = False) As String
'made to act similar on default as app.exename, but also has the option to seek root (or not)
'of modulated embedded code processes where callie' maybe the library or dll also obtainable
Dim lpTemp As String
Dim nLen As Long
lpTemp = Space(256)
If RootEXEOf Then
nLen = GetModuleFileName(0&, lpTemp, Len(lpTemp))
lpTemp = Left(lpTemp, nLen)
Else
nLen = GetModuleFileName(GetModuleHandle(App.EXEName), lpTemp, Len(lpTemp))
lpTemp = Left(lpTemp, nLen)
End If
If TitleOnly And InStrRev(lpTemp, "\") > 0 Then
lpTemp = Mid(lpTemp, InStrRev(lpTemp, "\") + 1)
End If
If TitleOnly And InStrRev(lpTemp, ".") = Len(lpTemp) - 3 Then
lpTemp = Left(lpTemp, InStrRev(lpTemp, ".") - 1)
End If
AppEXEName = Trim(lpTemp)
End Function
Public Function IsCompiled() As Boolean
'determines the possession of the running project if whether or not
'the active process instance is in a compiled sense of machine code
'/d VBIDE=0, or if it is in uncompiled pass CondComp="VBIDE=-1" if
'neither those conditions are met it still attempts to affirm by
'way of neither 100% accuracy of sub modulated checking the EXE
IsCompiled = True
#If VBIDE = 0 Then
On Error GoTo NotComp
IsCompiled = (LCase(Trim(App.EXEName)) = LCase(Trim(AppEXEName(True, False))))
If Not IsCompiled Then
Debug.Print 1 / 0
End If
#Else
 IsCompiled = False
 Exit Function
#End If
On Error GoTo NotComp
If Not IsCompiled Then
Debug.Print 1 / 0
End If
Exit Function
NotComp:
IsCompiled = False
End Function
Public Function IsCompiler() As Boolean
'checks for active process if directly is of vb6, the compiler
'and not the subderivitive or modulated sub there of, neither
If ("vb6" = LCase(AppEXEName(True, True))) Then
IsCompiler = True
Else
IsCompiler = False
End If
End Function
Public Function IsDebugger(Optional ByVal AppTitle As String = "") As Boolean
'Checks for the presense of the debugger in scope, or if apptitle
'supplied, that instance of title in a active debugger environment
'this can be any active open environment in relates to self/other
Dim nLen As String
Dim lpTemp As String
lpTemp = Space(256)
nLen = GetModuleFileName(0&, lpTemp, Len(lpTemp))
lpTemp = Left(lpTemp, nLen)
If (InStrRev(LCase(lpTemp), "vb6.exe") > 0) Then
IsDebugger = True
If AppTitle = "" Then AppTitle = App.Title
If AppTitle <> "" Then
IsDebugState = AppTitle & " - Microsoft Visual Basic"
Dim TmpHwnds As String
IsDebugHwnds = ""
EnumWindows AddressOf IsDebuggingWinEvents, GetCurrentProcessId
Do Until (IsDebugState <> AppTitle) Or ((IsDebugHwnds = TmpHwnds & IsDebugHwnds) And (TmpHwnds = ""))
TmpHwnds = TmpHwnds & IsDebugHwnds
DoEvents
If InStr(IsDebugHwnds, TmpHwnds) > 0 Then
IsDebugHwnds = TmpHwnds
TmpHwnds = IsDebugHwnds & IsDebugHwnds
Else
TmpHwnds = ""
End If
Loop
IsDebugger = (IsDebugState = "TRUE")
End If
Else
IsDebugger = False
End If
End Function


Other 16 submission(s) by this author

 


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this code (in the Intermediate category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.