VisualFreeBasic控件_VEH 崩溃处理

当软件发生崩溃后，就会触发本控件事件。

本控件功能只有一个，就是监控自己运行的软件，当软件发生崩溃的时候，系统会触发本控件事件，来执行事件，执行事件中，软件不会消失，继续运行，当执行事件里代码再发生崩溃，那么软件就真要崩溃了。

Function Form1_VEH1_VectExcepHandler(ByRef excp As EXCEPTION_POINTERS)As Integer
           保存软件崩溃日志(App.Path & "bug" & NowString(1) & ".txt" ,excp) '返回日志内容
End Function

excp 变量中，包含各自汇编级别的信息，下面代码提供保存的汇编内容

Function 保存软件崩溃日志(文件名 As String, excp As EXCEPTION_POINTERS) As String '返回日志内容
   Dim vi As OSVERSIONINFO
   vi.dwOsVersionInfoSize = SizeOf(OSVERSIONINFO)
   GetVersionEx @vi
   Dim bug As String = " OS 版本:      " & vi.dwMajorVersion & "." & vi.dwMinorVersion & "." & vi.dwBuildNumber & vbCrLf
   bug &= "区域设置 ID:   " & GetUserDefaultLangID & vbCrLf
   bug &= "应用程序名:    " & App.EXEName          & vbCrLf
   bug &= "应用程序版本:  " & App.ProductMajor     & "." & App.ProductMinor & "." & App.ProductRevision & "." & App.ProductBuild & vbCrLf
   Dim gzmk As String, AllMode As String, pianyi As UInteger, gzmkbb As String
   Dim ExceptionAddress As UInteger = Cast(UInteger, excp.ExceptionRecord->ExceptionAddress)
   Dim I As UInteger

   Dim bI      As Long, mSnapshot As HANDLE
   Dim Mode    As MODULEENTRY32
   Dim gMode() As MODULEENTRY32
   '----------------查找进程的执行程序的路径-----------------------
   '通过模块快照，获得进程的模块快照句柄
   mSnapshot = CreateToolhelp32Snapshot(&H8, GetCurrentProcessId()) 'Const TH32CS_SNAPmodule = &H8
   If mSnapshot > 0 Then
      Mode.dwSize = SizeOf(Mode) '初始化结构mo的大小
      '用该进程第1个模块的szExePath字段，作为进程的程序路径
      If Module32First(mSnapshot, @Mode) Then
         Do
            ReDim Preserve gMode(bi)
            gMode(bi) = Mode
            bi        = bi + 1
            AllMode   &= Hex(Mode.modBaseAddr, Len(UInteger) * 2) & " " & CWSTRtoString(Mode.szExePath) & "  [" & GetVersionInfo(Mode.szExePath) & "][" & GetFileLength(Mode.szExePath) & "]" & vbCrLf
            If ExceptionAddress > Cast(UInteger, Mode.modBaseAddr) And ExceptionAddress < Cast(UInteger, Mode.modBaseAddr) + Cast(UInteger, Mode.modBaseSize) Then
               gzmk   = CWSTRtoString(Mode.szModule)
               gzmkbb = GetVersionInfo(Mode.szExePath)
               pianyi = ExceptionAddress - Cast(UInteger, Mode.modBaseAddr)
            End if
         Loop Until Module32Next(mSnapshot, @Mode) = 0
      End If
      CloseHandle(mSnapshot) '关闭模块快照句柄
   End If

   '32位 寄存器 excp.ContextRecord->Eax Ebx Ecx Edx Ebp Esi Edi Eip
   '62位 寄存器 excp.ContextRecord->Rax Rbx Rcx Rdx Rbp Rsi Rdi Rip Rsp R8 R9 R10 R11 R12 R13 R14 R15

   bug &= "故障模块名称:  " & gzmk   & vbCrLf
   bug &= "故障模块版本:  " & gzmkbb & vbCrLf

   Dim ErrStr As String
   Select Case excp.ExceptionRecord->ExceptionCode '发生异常的原因。这是由硬件异常生成的代码，或在RaiseException函数中为软件生成的异常指定的代码 。
      Case EXCEPTION_ACCESS_VIOLATION
         ErrStr = "线程试图读取或写入对其没有适当访问权限的虚拟地址。"
      Case EXCEPTION_ARRAY_BOUNDS_EXCEEDED
         ErrStr = "线程尝试访问超出范围的数组元素，并且基础硬件支持范围检查。"
      Case EXCEPTION_BREAKPOINT
         ErrStr = "遇到断点。"
      Case EXCEPTION_DATATYPE_MISALIGNMENT
         ErrStr = "线程试图读取或写入在不提供对齐方式的硬件上未对齐的数据。例如，必须在2字节边界上对齐16位值；4字节边界上的32位值，依此类推。"
      Case EXCEPTION_FLT_DENORMAL_OPERAND
         ErrStr = "浮点运算中的操作数之一是非正规的。非标准值是一个太小而无法表示为标准浮点值的值。"
      Case EXCEPTION_FLT_DIVIDE_BY_ZERO
         ErrStr = "线程试图将浮点值除以零的浮点除数。"
      Case EXCEPTION_FLT_INEXACT_RESULT
         ErrStr = "浮点运算的结果不能完全表示为小数。"
      Case EXCEPTION_FLT_INVALID_OPERATION
         ErrStr = "此异常表示此列表中未包含的任何浮点异常。"
      Case EXCEPTION_FLT_OVERFLOW
         ErrStr = "浮点运算的指数大于相应类型所允许的大小。"
      Case EXCEPTION_FLT_STACK_CHECK
         ErrStr = "由于浮点运算，堆栈上溢或下溢。"
      Case EXCEPTION_FLT_UNDERFLOW
         ErrStr = "浮点运算的指数小于相应类型所允许的大小。"
      Case EXCEPTION_ILLEGAL_INSTRUCTION
         ErrStr = "线程试图执行无效指令。"
      Case EXCEPTION_IN_PAGE_ERROR
         ErrStr = "该线程试图访问一个不存在的页面，系统无法加载该页面。例如，如果通过网络运行程序时网络连接丢失，可能会发生此异常。"
      Case EXCEPTION_INT_DIVIDE_BY_ZERO
         ErrStr = "线程尝试将整数值除以零的整数除数。"
      Case EXCEPTION_INT_OVERFLOW
         ErrStr = "整数运算的结果导致对结果的最高有效位进行进位。"
      Case EXCEPTION_INVALID_DISPOSITION
         ErrStr = "异常处理程序将无效处置返回给异常调度程序。使用诸如C之类的高级语言的程序员应该永远不会遇到此异常。"
      Case EXCEPTION_NONCONTINUABLE_EXCEPTION
         ErrStr = "发生不可连续的异常后，线程尝试继续执行。"
      Case EXCEPTION_PRIV_INSTRUCTION
         ErrStr = "线程试图执行一条指令，该指令在当前机器模式下是不允许的。"
      Case EXCEPTION_SINGLE_STEP
         ErrStr = "跟踪陷阱或其他单指令机制表明已执行了一条指令。"
      Case EXCEPTION_STACK_OVERFLOW
         ErrStr = "线程耗尽了其堆栈。"
      Case Else
         ErrStr = "未知"
   End Select
   bug &= "异常代码:      " & Hex(excp.ExceptionRecord->ExceptionCode) & "  " & ErrStr & vbCrLf
   bug &= "异常偏移:      " & Hex(pianyi, 8) & vbCrLf

   #IfDef __FB_64BIT__
      bug &= "寄存器值:      Rax=" & Hex(excp.ContextRecord->Rax)
      If excp.ContextRecord->Rax > &H10000 Then bug &= " [Rax]=" & Hex(MEM_Read_ULongInt(GetCurrentProcessId, excp.ContextRecord->Rax))
      bug &= " Rbx=" & Hex(excp.ContextRecord->Rbx)
      If excp.ContextRecord->Rbx > &H10000 Then bug &= " [Rbx]=" & Hex(MEM_Read_ULongInt(GetCurrentProcessId, excp.ContextRecord->Rbx))
      bug &= " Rcx=" & Hex(excp.ContextRecord->Rcx)
      If excp.ContextRecord->Rcx > &H10000 Then bug &= " [Rcx]=" & Hex(MEM_Read_ULongInt(GetCurrentProcessId, excp.ContextRecord->Rcx))
      bug &= " Rdx=" & Hex(excp.ContextRecord->Rdx)
      If excp.ContextRecord->Rdx > &H10000 Then bug &= " [Rdx]=" & Hex(MEM_Read_ULongInt(GetCurrentProcessId, excp.ContextRecord->Rdx))
      bug &= " Rbp=" & Hex(excp.ContextRecord->Rbp)
      If excp.ContextRecord->Rbp > &H10000 Then bug &= " [Rbp]=" & Hex(MEM_Read_ULongInt(GetCurrentProcessId, excp.ContextRecord->Rbp))
      bug &= " Rsp=" & Hex(excp.ContextRecord->Rsp)
      If excp.ContextRecord->Rsp > &H10000 Then bug &= " [Rsp]=" & Hex(MEM_Read_ULongInt(GetCurrentProcessId, excp.ContextRecord->Rsp))
      bug &= " Rsi=" & Hex(excp.ContextRecord->Rsi)
      If excp.ContextRecord->Rsi > &H10000 Then bug &= " [Rsi]=" & Hex(MEM_Read_ULongInt(GetCurrentProcessId, excp.ContextRecord->Rsi))
      bug &= " Rdi=" & Hex(excp.ContextRecord->Rdi)
      If excp.ContextRecord->Rdi > &H10000 Then bug &= " [Rdi]=" & Hex(MEM_Read_ULongInt(GetCurrentProcessId, excp.ContextRecord->Rdi))
      bug &= " Rip=" & Hex(excp.ContextRecord->Rip) & vbCrLf
   #else
      bug &= "寄存器值:      Eax=" & Hex(excp.ContextRecord->Eax)
      If excp.ContextRecord->Eax > &H10000 Then bug &= " [Eax]=" & Hex(MEM_Read_ULong(GetCurrentProcessId, excp.ContextRecord->Eax))
      bug &= " Ebx=" & Hex(excp.ContextRecord->Ebx)
      If excp.ContextRecord->Ebx > &H10000 Then bug &= " [Ebx]=" & Hex(MEM_Read_ULong(GetCurrentProcessId, excp.ContextRecord->Ebx))
      bug &= " Ecx=" & Hex(excp.ContextRecord->Ecx)
      If excp.ContextRecord->Ecx > &H10000 Then bug &= " [Ecx]=" & Hex(MEM_Read_ULong(GetCurrentProcessId, excp.ContextRecord->Ecx))
      bug &= " Edx=" & Hex(excp.ContextRecord->Edx)
      If excp.ContextRecord->Edx > &H10000 Then bug &= " [Edx]=" & Hex(MEM_Read_ULong(GetCurrentProcessId, excp.ContextRecord->Edx))
      bug &= " Ebp=" & Hex(excp.ContextRecord->Ebp)
      If excp.ContextRecord->Ebp > &H10000 Then bug &= " [Ebp]=" & Hex(MEM_Read_ULong(GetCurrentProcessId, excp.ContextRecord->Ebp))
      bug &= " Esp=" & Hex(excp.ContextRecord->Esp)
      If excp.ContextRecord->Esp > &H10000 Then bug &= " [Esp]=" & Hex(MEM_Read_ULong(GetCurrentProcessId, excp.ContextRecord->Esp))
      bug &= " Esi=" & Hex(excp.ContextRecord->Esi)
      If excp.ContextRecord->Esi > &H10000 Then bug &= " [Esi]=" & Hex(MEM_Read_ULong(GetCurrentProcessId, excp.ContextRecord->Esi))
      bug &= " Edi=" & Hex(excp.ContextRecord->Edi)
      If excp.ContextRecord->Edi > &H10000 Then bug &= " [Edi]=" & Hex(MEM_Read_ULong(GetCurrentProcessId, excp.ContextRecord->Edi))
      bug &= " Eip=" & Hex(excp.ContextRecord->Eip) & vbCrLf
   #endif

   Dim 堆栈列表 As String, zdcc As UInteger, zdi As Long, sjStr As String, sjc As Long, zpi As Long, zk As Long = Len(UInteger) * 2, jcm As String
   Dim sp       As UInteger
   #IfDef __FB_64BIT__
      jcm = "[Rsp"
      I   = excp.ContextRecord->Rsp
      sp  = i
      While zdi < 30 And zpi < 100
         zdcc = MEM_Read_ULongInt(GetCurrentProcessId, I)
         i    += 8
   #Else
      jcm = "[Esp"
      I   = excp.ContextRecord->Esp
      sp  = i
      While zdi < 30 And zpi < 100
         zdcc = MEM_Read_ULong(GetCurrentProcessId, I)
         i    += 4
   #endif
      sjc = 0 '是不是查到模块
      zpi += 1
      if zdcc Then
         if zdcc > &H400000 Then
            For bI = 0 To UBound(gMode)
               if zdcc > Cast(UInteger, gMode(bI).modBaseAddr) And zdcc < Cast(UInteger, gMode(bI).modBaseAddr) + Cast(UInteger, gMode(bI).modBaseSize) Then
                  if Len(sjStr) Then '纯数据
                     堆栈列表 &= sjStr & vbCrLf
                     sjStr    = ""
                  End if
                  堆栈列表 &= jcm & "+" & Hex(i - sp, 4) & "]=" & Hex(zdcc, zk) & "  " & CWSTRtoString(gMode(bI).szModule) & "+" & Hex(zdcc - Cast(UInteger, gMode(bI).modBaseAddr)) & vbCrLf
                  sjc      = 1
                  zdi      += 1
                  Exit For
               End if
            Next
         End if
      End if
      if sjc = 0 Then
         If Len(sjStr) Then
            sjStr &= "," & Hex(zdcc, zk)
         Else
            sjStr = jcm & "+" & Hex(i - sp, 4) & "]=" & Hex(zdcc, zk)
         End if
      End if
   Wend
   if Len(sjStr) Then 堆栈列表 &= sjStr & vbCrLf

   Dim 局部列表 As String
   zdi = 9
   #IfDef __FB_64BIT__
      jcm = "[Rbp"
      I   = excp.ContextRecord->Rbp + 72
      While zdi > -121
         zdcc = MEM_Read_ULongInt(GetCurrentProcessId, i)
         i    -= 8
   #Else
      jcm = "[Ebp"
      I   = excp.ContextRecord->Ebp + 36
      While zdi > -121
         zdcc = MEM_Read_ULong(GetCurrentProcessId, i)
         i    -= 4
   #endif
      if zdi >= 0 then
         局部列表 &= jcm & "+" & Hex(zdi *Len(UInteger), 4) & "]=" & Hex(zdcc, zk) & " "
      ElseIf zdi < 0 Then
         局部列表 &= jcm & "-" & Hex(abs(zdi) *Len(UInteger), 4) & "]=" & Hex(zdcc, zk) & " "
      End if
      if (zdi Mod 10) = 0 Then 局部列表 &= vbCrLf
      zdi -= 1

   Wend

   bug &= "堆栈列表(栈顶): Esp/Rsp ------------------------------"       & vbCrLf & 堆栈列表
   bug &= "局部列表(栈底): Ebp/Rbp ------------------------------------" & vbCrLf & 局部列表
   bug &= "模块列表:   ------------------------------------------"       & vbCrLf & AllMode

   If Len(文件名) Then SaveFileStr 文件名, bug

   Function = bug

End Function