-
VisualFreeBasic控件_YFTreeView 目录树 和系统标准控件使用方法类似，主要不同的是图标使用字体图标 使用方法，添加数据 Dim aa As YFTreeViewData Ptr = YFTreeView1.AddItem(0, "文字1") aa = YFTreeView1.AddItem(0, "文字2") '需要添加子项目 Dim bb As YFTreeViewData Ptr =YFTreeView1.AddItem(aa, "子文字1") 支持图标 矢量图标 添加矢量图标 Redim YFTreeView1.vico(2) YFTreeView1.vico(1)="f00101UU.7UL[YZL`Y^B`UcP[_]iVVZ[VlUL[Y+c200Z^YnV_V_" '矢量图标字符串 YFTreeView1.vico(2)="a.42TP.7[sWraiWrai^F+a*6WKZPWK`n]C`n+b01TP00?T_T_Z[YF+b*6\t^QZ[YD" '矢量图标字符串 添加数据，带矢量图标索引 YFTreeView1.AddItem(0,"行文字1",0,1 ) YFTreeView1.AddItem(0,"行文字2",0,2 ) 字体图标 先要在起始代码区加载字体 字体文件在资源中 Dim ss As String = GetResourceStr("FONT_ICONFONT") Dim As Long uu Dim ff As Any Ptr = AddFontMemResourceEx(StrPtr(ss), Len(ss), 0, @uu) 字体文件是一个文件 Dim sst As String = App.Path & "iconfont.ttf" Dim As Long uu = AddFontResourceExA(StrPtr(sst) ,FR_PRIVATE ,0) 添加数据，带字体中的字符值 YFTreeView1.AddItem(0,"行文字1",0,&HE655) YFTreeView1.AddItem(0,"行文字2",0,&HE651 ) 图标文件 Dim H As HICON = LoadIcon(NULL, IDI_ERROR) ‘加载图标，不可以立即释放，等控件不显示了，必须释放 YFTreeView1.AddItem(0,"行文字2", 0,Cast(Integer, H)) 新增的全部参数 Dim aa As YFTreeViewData Ptr = YFTreeView1.AddItem(0, "文字1",用户数据,普通字体图标,展开字体图标,是否为目录,图标颜色,文字颜色,背景颜色,是否选中) 普通字体图标,展开字体图标 当目录时，展开和没展开可以设置不同的图标 是否为目录 当没有子项目时，也显示为有子项目的状态 是否选中 当控件有带复选框样式，那么选中就会显示打勾 自绘 在事件中，自己可以画 Function Form1_YFTreeView1_OwnerDraw(hWndForm As hWnd,hWndControl As hWnd,gg As yGDI , hItem As YFTreeViewData ,x As Long ,y As Long ,w As Long ,h As Long,Sel As Long ,kMouse As Long,kPress As Long,ByRef maxW As Long) As LResult gg.SetColor &H0000FF 'GDI的颜色值。RGB=255,0,0 nl.ShowWidth = gg.GetTextWidth(nL.sText) + x If maxW<nl.ShowWidth Then maxW=nl.ShowWidth '必须设置，控件才能判断出要不要显示水平滚动条。不需要水平滚动，可以不设置 gg.DrawTextS(x ,y ,w ,h ,nL.sText ,DT_VCENTER Or DT_SINGLELINE Or DT_NOPREFIX Or DT_WORD_ELLIPSIS) Return True Function = False ' 自己画了后需要应返回 TRUE 控件就不画了，不然控件会再画。 End Function 列遍目录树所有数据 '列遍目录树所有数据 -----------深度算法，从上到下，先查子再进入 Dim 当前项目 As YFTreeViewData Ptr Dim 下一个项目 As YFTreeViewData Ptr 下一个项目 = YFTreeView1.GetRoot '根 当前项目 = YFTreeView1.GetChild(下一个项目) '第一个项目 Do If 当前项目 = 0 Then Exit Do '无项目 '项目处理 ----------- Print 当前项目->DataValue, 当前项目->sText '这里是你自己写的处理代码 '继续列出下一个 ------------- 下一个项目 = YFTreeView1.GetChild(当前项目) '查找第一个子项目 If 下一个项目 Then 当前项目 = 下一个项目 Else 下一个项目 = YFTreeView1.GetNextSiblin(当前项目) '没有子项目，就查找下一个项目 If 下一个项目 Then 当前项目 = 下一个项目 Else '没有任何项目了，就返回到父项目 Do 下一个项目 = YFTreeView1.GetParent(当前项目) If 下一个项目 = 0 OrElse 下一个项目 = YFTreeView1.GetRoot Then Exit Do, Do '已经到顶了，无项目处理，退出 当前项目 = YFTreeView1.GetNextSiblin(下一个项目) If 当前项目 Then Exit Do '有项目 当前项目 = 下一个项目 '已经到底，再向上一级别 Loop End If End If Loop 动态加载数据 比方要显示一个教程，教程中有很多目录，可能目录非常多，几千几万的，你要一次加载就非常缓慢。我们可以动态加载来实现，速度非常快，又能正常显示所有目录。 方法： 只加载根目录，有子项目的在添加时，“是否为目录”参数设置为 1 在“某结点将被展开”事件中，加载此子项目。 Function Form1_YFTreeView1_ItemExpanding(hWndForm As hWnd, hWndControl As hWnd,hItem As YFTreeViewData Ptr,action As Long )As LResult Function = False 'TRUE 可防止列表扩展或折叠。 End Function 例：新增项目时，在“用户数据”中赋值 数据库ID，那么在展开事件中，可以根据ID来加载数据了。 图标制作 使用 VisualFreeBasic 自带的 【矢量图标编辑器】 编辑一个，里面自带了很多图标，可以复制过来即可，在 VFB里的 工具菜单里，就可以找到这个软件。 -
VisualFreeBasic控件_YFList 列表 只为显示列表用，支持图标、自绘、每行颜色 等 使用方法 和标准控件的一样用法，就添加列表数据 YFList1.AddItem("列表文字1" ) YFList1.AddItem("列表文字2" ) YFList1.AddItem("列表文字3" ) 支持图标 矢量图标 添加矢量图标 Redim YFList1.vico(2) YFList1.vico(1)="f00101UU.7UL[YZL`Y^B`UcP[_]iVVZ[VlUL[Y+c200Z^YnV_V_" '矢量图标字符串 YFList1.vico(2)="a.42TP.7[sWraiWrai^F+a*6WKZPWK`n]C`n+b01TP00?T_T_Z[YF+b*6\t^QZ[YD" '矢量图标字符串 添加数据，带矢量图标索引 YFList1.AddItem("行文字1",1 ) YFList1.AddItem("行文字2",2 ) 字体图标 先要在起始代码区加载字体 字体文件在资源中 Dim ss As String = GetResourceStr("FONT_ICONFONT") Dim As Long uu Dim ff As Any Ptr = AddFontMemResourceEx(StrPtr(ss), Len(ss), 0, @uu) 字体文件是一个文件 Dim sst As String = App.Path & "iconfont.ttf" Dim As Long uu = AddFontResourceExA(StrPtr(sst) ,FR_PRIVATE ,0) 添加数据，带字体中的字符值 YFList1.AddItem("行文字1",&HE655) YFList1.AddItem("行文字2",&HE651 ) 图标文件 Dim H As HICON = LoadIcon(NULL, IDI_ERROR) ‘加载图标，不可以立即释放，等控件不显示了，必须释放 YFList1.AddItem("行文字2", Cast(Integer, H)) 其它颜色设置 （注意：是否选中，需要先设计属性显示复选框才有显示效果） YFList1.AddItem("列表文字1",字体图标,用户自定义数据,图标颜色,文字颜色,是否选中,背景颜色) 自绘 可以自己绘画，让控件更个性化 Function Form1_YFList1_OwnerDraw(hWndForm As hWnd,hWndControl As hWnd,StartY As Long,ItemHeight As Long ,sumU As Long,nList As YFListData Ptr,selIndex As Long,kMouse As Long,kPress As Long) As LResult End Function 自动生成的事件，里面还带详细的例题，可以看例题学习。 图标制作 使用 VisualFreeBasic 自带的 【矢量图标编辑器】 编辑一个，里面自带了很多图标，可以复制过来即可，在 VFB里的 工具菜单里，就可以找到这个软件。 -
-
VisualFreeBasic控件_YFscroll 滚动条 左右或上下，分割窗口，动态调节的分割条 此控件的功能非常简单，就在窗口上面，你点鼠标可以拖动位置，拖动后触发事件 Sub Form1_YFsplitBar1_DragStart(hWndForm As hWnd, hWndControl As hWnd,vv As Long ) End Sub 在事件中，你可以对窗口中的控件进行调整位置，来达到分割窗口控件的目的。 同一个控件，会根据长高，自动识别是 左右或上下 分割。 注：YFsplitBar1.Value 和 YFsplitBar1.Left 是同一个值，设置控件位置时，注意系统DPI 使用以下函数来处理DPI DpiScaleF DpiScaleI DpiUnScaleF DpiUnScaleI -
VisualFreeBasic控件_SpVoice TTS文本转语音 调用WIN系统里的TTS，把文本转换为语音输出，XP 系统中没测试，可能无效。 SpVoice1.Speak("我是中国人我骄傲") 事件中可以输出读取的文字 '[Form1.SpVoice1]事件 : 事件通知 'hWndForm 当前窗口的句柄(WIN系统用来识别窗口的一个编号，如果多开本窗口，必须 Me.hWndForm = hWndForm 后才可以执行后续操作本窗口的代码) 'SpVoice tts的对象 Sub Form1_SpVoice1_Notify(hWndForm As hWnd, ByRef SpVoice As Afx_ISpVoice) Dim eventItem As SPEVENT, eventStatus As SPVOICESTATUS If pSpVoice.GetEvents(1, @eventItem, NULL) = S_OK Then If eventItem.eEventId = SPEI_WORD_BOUNDARY Then pSpVoice.GetStatus(@eventStatus, NULL) Dim nStart As Long = eventStatus.ulInputWordPos '播放第几个字符，从 0开始，第一个字符，这里是 0 Dim nLen As Long = eventStatus.ulInputWordLen '几个字符， Print nStart, nLen End If End If '暂时只掌握这么多，等以后学的新知识了再扩展。 End Sub -
VisualFreeBasic控件_YFbunGroup 按钮组 可以添加一系列按钮 使用方法 拖控件到窗口后，在设计属性中，添加按钮 双击控件，产生事件，将会有自动产生Select Function Form1_YFbunGroup1_Command(hWndForm As hWnd, hWndControl As hWnd, nID As Long ) As Long Select Case nID Case Form1_YFbunGroup1_Button_1 ' Case Form1_YFbunGroup1_Button_2 ' Case Form1_YFbunGroup1_Button_3 ' Case Form1_YFbunGroup1_Button_4 ' End Select Function = TRUE ' 如果你处理了事件，就返回 Return TRUE ,控件就不进行默认处理了。 End Function 设置图标 本控件使用字体图标或图标文件，设计模式添加按钮时，可以选择相关图标 运行后才有效果。 图标制作 使用 VisualFreeBasic 自带的 【矢量图标编辑器】 编辑一个，里面自带了很多图标，可以复制过来即可，在 VFB里的 工具菜单里，就可以找到这个软件。 -
VisualFreeBasic控件_YFproTab 加强版标签 标签，多标签控件，如同浏览器上的标签一样。可以拖动交换位置。 有多种样式，样式也可以设置，具体效果，可以自己选择了看。 主要事件 使用方法 先给每个页面添加一个 子窗口的窗口 Dim 页面窗口 As hWnd =Form2.Show(hWndForm) YFproTab1.AddTab(页面窗口,"标签文字1","提示文字1",矢量图标字符串) 页面窗口 =Form3.Show(hWndForm) YFproTab1.AddTab(页面窗口,"标签文字2","提示文字2",矢量图标字符串) 图标制作 使用 VisualFreeBasic 自带的 【矢量图标编辑器】 编辑一个，里面自带了很多图标，可以复制过来即可，在 VFB里的 工具菜单里，就可以找到这个软件。 -
VisualFreeBasic控件_HotKey 热键 热键、快捷键，2种功能 热键使用方法 先向系统注册，要是系统中其它软件已经注册过相同的，那么会被我们抢注，假如我们注册后，其它软件再注册相同的，那么就被其它软件抢注。我们软件就失效。 HotKey1.AddHotKey(虚拟键码,组合键 ) 虚拟键码: https://docs.microsoft.com/en-us/windows/win32/inputdev/virtual-key-codes 组合键： MOD_ALT(ALT键) MOD_CONTROL(CTRL键) MOD_SHIFT(SHIFT键) MOD_WIN(WINDOWS键) 按下热键，触发事件 Sub Form1_HotKey1_KeyboardState(hWndForm As hWnd, vKey As Long ,fsModifiers As Long) If (fsModifiers And MOD_ALT)=MOD_ALT Then Print "有ALT键按下" If (fsModifiers And 16) = 16 Then Print "键被按下" Else Print "键被放开" Select Case vKey Case VK_LBUTTON ,VK_RBUTTON '鼠标 Case &H30 To &H39 '0 -- 9 Case &H41 To &H5A 'A -- Z Case &H60 To &H69 '数字键盘 0 -- 9 Case VK_F1 To VK_F24 'F1 -- F24 键 End Select End Sub 快捷键使用方法 不需要注册，不需要代码，就选中事件即可，就会有按钮事件，假如其它软件也使用相同的，大家都会被触发。 这个事件，只要键盘的任意键被按下，都触发本事件，然后自己判断按下了什么键。 Sub Form1_HotKey1_KeyboardState(hWndForm As hWnd, vKey As Long ,fsModifiers As Long) If (fsModifiers And MOD_ALT)=MOD_ALT Then Print "有ALT键按下" If (fsModifiers And 16) = 16 Then Print "键被按下" Else Print "键被放开" Select Case vKey Case VK_LBUTTON ,VK_RBUTTON '鼠标 Case &H30 To &H39 '0 -- 9 Case &H41 To &H5A 'A -- Z Case &H60 To &H69 '数字键盘 0 -- 9 Case VK_F1 To VK_F24 'F1 -- F24 键 End Select End Sub -
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 -
VisualFreeBasic控件_WinHook 系统钩子 系统钩子（System Hooks）在编程中，特别是在Windows操作系统环境下，是一种强大的机制，允许应用程序拦截、监视或修改系统级事件。这些事件可以包括键盘和鼠标输入、消息传递、窗口创建和销毁等。通过使用钩子，开发者可以创建出功能强大的应用程序，如键盘记录器、屏幕捕获工具、游戏作弊软件等，但同时也需要谨慎使用，以避免侵犯用户隐私或违反软件许可协议。 钩子类型 Windows提供了多种类型的钩子，根据你想要拦截的事件类型来选择： WH_CALLWNDPROC 和 WH_CALLWNDPROCRET：这些钩子允许你监视发送到窗口过程的消息。前者在消息被处理前调用，后者在消息被处理后调用。 WH_CBT：CBT（Callback to Task Window）钩子允许你监视Windows的各种系统级操作，如窗口的创建和销毁。 WH_DEBUG：调试钩子，主要用于调试目的，允许你监视和记录系统级事件。 WH_FOREGROUNDIDLE：当系统前台线程处于空闲状态时，此钩子被调用。它允许应用程序执行后台任务而不影响用户界面的响应性。 WH_GETMESSAGE 和 WH_JOURNALRECORD：这两个钩子与消息队列有关。WH_GETMESSAGE在消息从消息队列中检索之前被调用，而WH_JOURNALRECORD用于记录输入事件（如键盘和鼠标事件）到日志文件中。 WH_KEYBOARD 和 WH_KEYBOARD_LL：键盘钩子，用于监视键盘输入。WH_KEYBOARD是低级钩子，它在系统级别拦截键盘事件，而WH_KEYBOARD_LL是更底层的钩子，它在Windows的底层键盘驱动程序中拦截事件。 WH_MOUSE 和 WH_MOUSE_LL：鼠标钩子，与键盘钩子类似，但用于监视鼠标输入。 WH_MSGFILTER 和 WH_SYSMSGFILTER：这两个钩子允许应用程序在消息到达窗口过程之前过滤掉某些消息。WH_MSGFILTER仅适用于与钩子安装线程相关联的窗口，而WH_SYSMSGFILTER则适用于系统中的所有线程。 WH_SHELL：外壳钩子，用于监视与外壳相关的通知，如窗口的激活和最小化。 使用钩子的注意事项 性能影响：安装钩子可能会对系统性能产生负面影响，尤其是全局钩子（如WH_KEYBOARD_LL和WH_MOUSE_LL），因为它们会影响整个系统的输入事件。 权限要求：某些类型的钩子需要管理员权限才能安装。 安全性和隐私：由于钩子可以监视和修改用户的输入，因此它们可能被用于恶意目的。确保你的应用程序尊重用户的隐私和安全。 兼容性：随着Windows版本的更新，钩子的行为可能会发生变化。确保你的应用程序与目标操作系统版本兼容。 卸载钩子：在应用程序退出或不再需要钩子时，应确保卸载钩子以避免资源泄漏或意外行为。 钩子控件的使用方法 使用方法非常简单，无需你写任何代码，只要选择相关事件即可。没选择的事件并不会去钩操作系统里的东西，也不影响系统速度。钩子会影响操作系统性能。只要你创建了事件，那么就创建了钩子。没创建就没钩子。 为了不影响系统性能，你需要在事件中执行代码尽量简单。